diff options
Diffstat (limited to 'libgfortran/io/read.c')
| -rw-r--r-- | libgfortran/io/read.c | 793 |
1 files changed, 793 insertions, 0 deletions
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c new file mode 100644 index 00000000000..3ce9f1d3a1a --- /dev/null +++ b/libgfortran/io/read.c @@ -0,0 +1,793 @@ +/* Copyright (C) 2002-2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of the GNU Fortran 95 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 +the Free Software Foundation; either version 2, or (at your option) +any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +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. */ + + +#include "config.h" +#include <string.h> +#include <errno.h> +#include <ctype.h> +#include <stdlib.h> +#include "libgfortran.h" +#include "io.h" + +/* read.c -- Deal with formatted reads */ + +/* set_integer()-- All of the integer assignments come here to + * actually place the value into memory. */ + +void +set_integer (void *dest, int64_t value, int length) +{ + + switch (length) + { + case 8: + *((int64_t *) dest) = value; + break; + case 4: + *((int32_t *) dest) = value; + break; + case 2: + *((int16_t *) dest) = value; + break; + case 1: + *((int8_t *) dest) = value; + break; + default: + internal_error ("Bad integer kind"); + } +} + + +/* max_value()-- Given a length (kind), return the maximum signed or + * unsigned value */ + +uint64_t +max_value (int length, int signed_flag) +{ + uint64_t value; + + switch (length) + { + case 8: + value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff; + break; + case 4: + value = signed_flag ? 0x7fffffff : 0xffffffff; + break; + case 2: + value = signed_flag ? 0x7fff : 0xffff; + break; + case 1: + value = signed_flag ? 0x7f : 0xff; + break; + default: + internal_error ("Bad integer kind"); + } + + return value; +} + + +/* convert_real()-- Convert a character representation of a floating + * point number to the machine number. Returns nonzero if there is a + * range problem during conversion. TODO: handle not-a-numbers and + * infinities. Handling of kind 4 is probably wrong because of double + * rounding. */ + +int +convert_real (void *dest, const char *buffer, int length) +{ + + errno = 0; + + switch (length) + { + case 4: + *((float *) dest) = (float) strtod (buffer, NULL); + break; + case 8: + *((double *) dest) = strtod (buffer, NULL); + break; + default: + internal_error ("Bad real number kind"); + } + + if (errno != 0) + { + generate_error (ERROR_READ_VALUE, + "Range error during floating point read"); + return 1; + } + + return 0; +} + +static int +convert_precision_real (void *dest, int sign, + char *buffer, int length, int exponent) +{ + int w, new_dp_pos, i, slen, k, dp; + char * p, c; + double fval; + float tf; + + fval =0.0; + tf = 0.0; + dp = 0; + new_dp_pos = 0; + + slen = strlen (buffer); + w = slen; + p = buffer; + +/* for (i = w - 1; i > 0; i --) + { + if (buffer[i] == '0' || buffer[i] == 0) + buffer[i] = 0; + else + break; + } +*/ + for (i = 0; i < w; i++) + { + if (buffer[i] == '.') + break; + } + + new_dp_pos = i; + new_dp_pos += exponent; + + while (w > 0) + { + c = *p; + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + fval = fval * 10.0 + c - '0'; + p++; + w--; + break; + + case '.': + dp = 1; + p++; + w--; + break; + + default: + p++; + w--; + break; + } + } + + if (sign) + fval = - fval; + + i = new_dp_pos - slen + dp; + k = abs(i); + tf = 1.0; + + while (k > 0) + { + tf *= 10.0 ; + k -- ; + } + + if (fval != 0.0) + { + if (i < 0) + { + fval = fval / tf; + } + else + { + fval = fval * tf; + } + } + + switch (length) + { + case 4: + *((float *) dest) = (float)fval; + break; + case 8: + *((double *) dest) = fval; + break; + default: + internal_error ("Bad real number kind"); + } + + return 0; +} + + +/* read_l()-- Read a logical value */ + +void +read_l (fnode * f, char *dest, int length) +{ + char *p; + int w; + + w = f->u.w; + p = read_block (&w); + if (p == NULL) + return; + + while (*p == ' ') + { + if (--w == 0) + goto bad; + p++; + } + + if (*p == '.') + { + if (--w == 0) + goto bad; + p++; + } + + switch (*p) + { + case 't': + case 'T': + set_integer (dest, 1, length); + break; + case 'f': + case 'F': + set_integer (dest, 0, length); + break; + default: + bad: + generate_error (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) +{ + char *source; + int w, m, n; + + w = f->u.w; + if (w == -1) /* '(A)' edit descriptor */ + w = length; + + source = read_block (&w); + if (source == NULL) + return; + if (w > length) + source += (w - length); + + m = (w > length) ? length : w; + memcpy (p, source, m); + + n = length - w; + if (n > 0) + memset (p + m, ' ', n); +} + + +/* eat_leading_spaces()-- Given a character pointer and a width, + * ignore the leading spaces. */ + +static char * +eat_leading_spaces (int *width, char *p) +{ + + for (;;) + { + if (*width == 0 || *p != ' ') + break; + + (*width)--; + p++; + } + + return p; +} + + +static char +next_char (char **p, int *w) +{ + char c, *q; + + if (*w == 0) + return '\0'; + + q = *p; + c = *q++; + *p = q; + + (*w)--; + + if (c != ' ') + return c; + if (g.blank_status == BLANK_ZERO) + return '0'; + + /* At this point, the rest of the field has to be trailing blanks */ + + while (*w > 0) + { + if (*q++ != ' ') + return '?'; + (*w)--; + } + + *p = q; + return '\0'; +} + + +/* read_decimal()-- Read a decimal integer value. The values here are + * signed values. */ + +void +read_decimal (fnode * f, char *dest, int length) +{ + unsigned value, maxv, maxv_10; + int v, w, negative; + char c, *p; + + w = f->u.w; + p = read_block (&w); + if (p == NULL) + return; + + p = eat_leading_spaces (&w, p); + if (w == 0) + { + set_integer (dest, 0, length); + return; + } + + maxv = max_value (length, 1); + maxv_10 = maxv / 10; + + negative = 0; + value = 0; + + switch (*p) + { + case '-': + negative = 1; + /* Fall through */ + + case '+': + p++; + if (--w == 0) + goto bad; + /* Fall through */ + + default: + break; + } + + /* At this point we have a digit-string */ + value = 0; + + for (;;) + { + c = next_char (&p, &w); + if (c == '\0') + break; + + if (c < '0' || c > '9') + goto bad; + + if (value > maxv_10) + goto overflow; + + c -= '0'; + value = 10 * value; + + if (value > maxv - c) + goto overflow; + value += c; + } + + v = (signed int) value; + if (negative) + v = -v; + + set_integer (dest, v, length); + return; + +bad: + generate_error (ERROR_READ_VALUE, "Bad value during integer read"); + return; + +overflow: + generate_error (ERROR_READ_OVERFLOW, + "Value overflowed during integer read"); + return; +} + + +/* read_radix()-- This function reads values for non-decimal radixes. + * The difference here is that we treat the values here as unsigned + * values for the purposes of overflow. If minus sign is present and + * the top bit is set, the value will be incorrect. */ + +void +read_radix (fnode * f, char *dest, int length, int radix) +{ + unsigned value, maxv, maxv_r; + int v, w, negative; + char c, *p; + + w = f->u.w; + p = read_block (&w); + if (p == NULL) + return; + + p = eat_leading_spaces (&w, p); + if (w == 0) + { + set_integer (dest, 0, length); + return; + } + + maxv = max_value (length, 0); + maxv_r = maxv / radix; + + negative = 0; + value = 0; + + switch (*p) + { + case '-': + negative = 1; + /* Fall through */ + + case '+': + p++; + if (--w == 0) + goto bad; + /* Fall through */ + + default: + break; + } + + /* At this point we have a digit-string */ + value = 0; + + for (;;) + { + c = next_char (&p, &w); + if (c == '\0') + break; + + switch (radix) + { + case 2: + if (c < '0' || c > '1') + goto bad; + break; + + case 8: + if (c < '0' || c > '7') + goto bad; + break; + + case 16: + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + break; + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + c = c - 'a' + '9' + 1; + break; + + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + c = c - 'A' + '9' + 1; + break; + + default: + goto bad; + } + + break; + } + + if (value > maxv_r) + goto overflow; + + c -= '0'; + value = radix * value; + + if (maxv - c < value) + goto overflow; + value += c; + } + + v = (signed int) value; + if (negative) + v = -v; + + set_integer (dest, v, length); + return; + +bad: + generate_error (ERROR_READ_VALUE, "Bad value during integer read"); + return; + +overflow: + generate_error (ERROR_READ_OVERFLOW, + "Value overflowed during integer read"); + return; +} + + +/* read_f()-- Read a floating point number with F-style editing, which + * is what all of the other floating point descriptors behave as. The + * tricky part is that optional spaces are allowed after an E or D, + * and the implicit decimal point if a decimal point is not present in + * the input. */ + +void +read_f (fnode * f, char *dest, int length) +{ + int w, seen_dp, exponent; + int exponent_sign, val_sign; + char *p, *buffer, *n; + + val_sign = 0; + seen_dp = 0; + w = f->u.w; + p = read_block (&w); + if (p == NULL) + return; + + p = eat_leading_spaces (&w, p); + if (w == 0) + { + switch (length) + { + case 4: + *((float *) dest) = 0.0; + break; + + case 8: + *((double *) dest) = 0.0; + break; + } + + return; + } + + if (w + 2 < SCRATCH_SIZE) + buffer = scratch; + else + buffer = get_mem (w + 2); + + memset(buffer, 0, w + 2); + + n = buffer; + + /* Optional sign */ + + if (*p == '-' || *p == '+') + { + if (*p == '-') + val_sign = 1; + p++; + + if (--w == 0) + goto bad_float; + } + + exponent_sign = 1; + + /* A digit (or a '.') is required at this point */ + + if (!isdigit (*p) && *p != '.') + goto bad_float; + + while (w > 0) + { + switch (*p) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + *n++ = *p++; + w--; + break; + + case '.': + if (seen_dp) + goto bad_float; + seen_dp = 1; + + *n++ = *p++; + w--; + break; + + case ' ': + if (g.blank_status == BLANK_ZERO) + *n++ = '0'; + p++; + w--; + break; + + case '-': + exponent_sign = -1; + /* Fall through */ + + case '+': + p++; + w--; + goto exp2; + + case 'd': + case 'e': + case 'D': + case 'E': + p++; + w--; + goto exp1; + + default: + goto bad_float; + } + } + +/* No exponent has been seen, so we use the current scale factor */ + + exponent = -g.scale_factor; + goto done; + +bad_float: + generate_error (ERROR_READ_VALUE, "Bad value during floating point read"); + if (buffer != scratch) + free_mem (buffer); + return; + +/* At this point the start of an exponent has been found */ + +exp1: + while (w > 0 && *p == ' ') + { + w--; + p++; + } + + switch (*p) + { + case '-': + exponent_sign = -1; + /* Fall through */ + + case '+': + p++; + w--; + break; + } + + if (w == 0) + goto bad_float; + +/* At this point a digit string is required. We calculate the value + * of the exponent in order to take account of the scale factor and + * the d parameter before explict conversion takes place. */ + +exp2: + if (!isdigit (*p)) + goto bad_float; + + exponent = *p - '0'; + p++; + w--; + + while (w > 0 && isdigit (*p)) + { + exponent = 10 * exponent + *p - '0'; + if (exponent > 999999) + goto bad_float; + + p++; + w--; + } + + /* Only allow trailing blanks */ + + while (w > 0) + { + if (*p != ' ') + goto bad_float; + p++; + w--; + } + + exponent = exponent * exponent_sign; + +done: + if (!seen_dp) + exponent -= f->u.real.d; + + /* The number is syntactically correct and ready for conversion. + * The only thing that can go wrong at this point is overflow or + * underflow. */ + + convert_precision_real (dest, val_sign, buffer, length, exponent); + + if (buffer != scratch) + free_mem (buffer); + + return; +} + + +/* read_x()-- Deal with the X/TR descriptor. We just read some data + * and never look at it. */ + +void +read_x (fnode * f) +{ + int n; + + n = f->u.n; + read_block (&n); +} |