1 /* Copyright (C) 2002, 2003, 2005, 2007 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. */
36 /* read.c -- Deal with formatted reads */
38 /* set_integer()-- All of the integer assignments come here to
39 * actually place the value into memory. */
42 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
46 #ifdef HAVE_GFC_INTEGER_16
49 GFC_INTEGER_16 tmp = value;
50 memcpy (dest, (void *) &tmp, length);
56 GFC_INTEGER_8 tmp = value;
57 memcpy (dest, (void *) &tmp, length);
62 GFC_INTEGER_4 tmp = value;
63 memcpy (dest, (void *) &tmp, length);
68 GFC_INTEGER_2 tmp = value;
69 memcpy (dest, (void *) &tmp, length);
74 GFC_INTEGER_1 tmp = value;
75 memcpy (dest, (void *) &tmp, length);
79 internal_error (NULL, "Bad integer kind");
84 /* max_value()-- Given a length (kind), return the maximum signed or
88 max_value (int length, int signed_flag)
90 GFC_UINTEGER_LARGEST value;
91 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
97 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
101 for (n = 1; n < 4 * length; n++)
102 value = (value << 2) + 3;
108 value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
111 value = signed_flag ? 0x7fffffff : 0xffffffff;
114 value = signed_flag ? 0x7fff : 0xffff;
117 value = signed_flag ? 0x7f : 0xff;
120 internal_error (NULL, "Bad integer kind");
127 /* convert_real()-- Convert a character representation of a floating
128 * point number to the machine number. Returns nonzero if there is a
129 * range problem during conversion. TODO: handle not-a-numbers and
133 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
142 #if defined(HAVE_STRTOF)
143 strtof (buffer, NULL);
145 (GFC_REAL_4) strtod (buffer, NULL);
147 memcpy (dest, (void *) &tmp, length);
152 GFC_REAL_8 tmp = strtod (buffer, NULL);
153 memcpy (dest, (void *) &tmp, length);
156 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
159 GFC_REAL_10 tmp = strtold (buffer, NULL);
160 memcpy (dest, (void *) &tmp, length);
164 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
167 GFC_REAL_16 tmp = strtold (buffer, NULL);
168 memcpy (dest, (void *) &tmp, length);
173 internal_error (&dtp->common, "Unsupported real kind during IO");
178 generate_error (&dtp->common, LIBERROR_READ_VALUE,
179 "Error during floating point read");
180 next_record (dtp, 1);
188 /* read_l()-- Read a logical value */
191 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
197 p = read_block (dtp, &w);
219 set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
223 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
227 generate_error (&dtp->common, LIBERROR_READ_VALUE,
228 "Bad value on logical read");
229 next_record (dtp, 1);
235 /* read_a()-- Read a character record. This one is pretty easy. */
238 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
244 if (w == -1) /* '(A)' edit descriptor */
247 dtp->u.p.sf_read_comma = 0;
248 source = read_block (dtp, &w);
249 dtp->u.p.sf_read_comma = 1;
253 source += (w - length);
255 m = (w > length) ? length : w;
256 memcpy (p, source, m);
260 memset (p + m, ' ', n);
264 /* eat_leading_spaces()-- Given a character pointer and a width,
265 * ignore the leading spaces. */
268 eat_leading_spaces (int *width, char *p)
272 if (*width == 0 || *p != ' ')
284 next_char (st_parameter_dt *dtp, char **p, int *w)
299 if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
300 return ' '; /* return a blank to signal a null */
302 /* At this point, the rest of the field has to be trailing blanks */
316 /* read_decimal()-- Read a decimal integer value. The values here are
320 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
322 GFC_UINTEGER_LARGEST value, maxv, maxv_10;
323 GFC_INTEGER_LARGEST v;
328 p = read_block (dtp, &w);
332 p = eat_leading_spaces (&w, p);
335 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
339 maxv = max_value (length, 1);
361 /* At this point we have a digit-string */
366 c = next_char (dtp, &p, &w);
372 if (dtp->u.p.blank_status == BLANK_NULL) continue;
373 if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
376 if (c < '0' || c > '9')
385 if (value > maxv - c)
394 set_integer (dest, v, length);
398 generate_error (&dtp->common, LIBERROR_READ_VALUE,
399 "Bad value during integer read");
400 next_record (dtp, 1);
404 generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
405 "Value overflowed during integer read");
406 next_record (dtp, 1);
411 /* read_radix()-- This function reads values for non-decimal radixes.
412 * The difference here is that we treat the values here as unsigned
413 * values for the purposes of overflow. If minus sign is present and
414 * the top bit is set, the value will be incorrect. */
417 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
420 GFC_UINTEGER_LARGEST value, maxv, maxv_r;
421 GFC_INTEGER_LARGEST v;
426 p = read_block (dtp, &w);
430 p = eat_leading_spaces (&w, p);
433 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
437 maxv = max_value (length, 0);
438 maxv_r = maxv / radix;
459 /* At this point we have a digit-string */
464 c = next_char (dtp, &p, &w);
469 if (dtp->u.p.blank_status == BLANK_NULL) continue;
470 if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
476 if (c < '0' || c > '1')
481 if (c < '0' || c > '7')
506 c = c - 'a' + '9' + 1;
515 c = c - 'A' + '9' + 1;
529 value = radix * value;
531 if (maxv - c < value)
540 set_integer (dest, v, length);
544 generate_error (&dtp->common, LIBERROR_READ_VALUE,
545 "Bad value during integer read");
546 next_record (dtp, 1);
550 generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
551 "Value overflowed during integer read");
552 next_record (dtp, 1);
557 /* read_f()-- Read a floating point number with F-style editing, which
558 is what all of the other floating point descriptors behave as. The
559 tricky part is that optional spaces are allowed after an E or D,
560 and the implicit decimal point if a decimal point is not present in
564 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
566 int w, seen_dp, exponent;
567 int exponent_sign, val_sign;
573 char scratch[SCRATCH_SIZE];
578 p = read_block (dtp, &w);
582 p = eat_leading_spaces (&w, p);
588 if (*p == '-' || *p == '+')
597 p = eat_leading_spaces (&w, p);
601 /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
602 is required at this point */
604 if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
605 && *p != 'e' && *p != 'E')
608 /* Remember the position of the first digit. */
612 /* Scan through the string to find the exponent. */
661 /* No exponent has been seen, so we use the current scale factor */
662 exponent = -dtp->u.p.scale_factor;
666 generate_error (&dtp->common, LIBERROR_READ_VALUE,
667 "Bad value during floating point read");
668 next_record (dtp, 1);
671 /* The value read is zero */
676 *((GFC_REAL_4 *) dest) = 0;
680 *((GFC_REAL_8 *) dest) = 0;
683 #ifdef HAVE_GFC_REAL_10
685 *((GFC_REAL_10 *) dest) = 0;
689 #ifdef HAVE_GFC_REAL_16
691 *((GFC_REAL_16 *) dest) = 0;
696 internal_error (&dtp->common, "Unsupported real kind during IO");
700 /* At this point the start of an exponent has been found */
702 while (w > 0 && *p == ' ')
723 /* At this point a digit string is required. We calculate the value
724 of the exponent in order to take account of the scale factor and
725 the d parameter before explict conversion takes place. */
734 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
736 while (w > 0 && isdigit (*p))
738 exponent = 10 * exponent + *p - '0';
743 /* Only allow trailing blanks */
753 else /* BZ or BN status is enabled */
759 if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
760 if (dtp->u.p.blank_status == BLANK_NULL)
767 else if (!isdigit (*p))
770 exponent = 10 * exponent + *p - '0';
776 exponent = exponent * exponent_sign;
779 /* Use the precision specified in the format if no decimal point has been
782 exponent -= f->u.real.d;
801 i = ndigits + edigits + 1;
805 if (i < SCRATCH_SIZE)
808 buffer = get_mem (i);
810 /* Reformat the string into a temporary buffer. As we're using atof it's
811 easiest to just leave the decimal point in place. */
815 for (; ndigits > 0; ndigits--)
819 if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
820 if (dtp->u.p.blank_status == BLANK_NULL)
831 sprintf (p, "%d", exponent);
833 /* Do the actual conversion. */
834 convert_real (dtp, dest, buffer, length);
836 if (buffer != scratch)
843 /* read_x()-- Deal with the X/TR descriptor. We just read some data
844 * and never look at it. */
847 read_x (st_parameter_dt *dtp, int n)
849 if (!is_stream_io (dtp))
851 if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
852 && dtp->u.p.current_unit->bytes_left < n)
853 n = dtp->u.p.current_unit->bytes_left;
855 dtp->u.p.sf_read_comma = 0;
857 read_sf (dtp, &n, 1);
858 dtp->u.p.sf_read_comma = 1;
861 dtp->u.p.current_unit->strm_pos += (gfc_offset) n;