void read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { int w, seen_dp, exponent; int exponent_sign; const char *p; char *buffer; char *out; int seen_int_digit; /* Seen a digit before the decimal point? */ int seen_dec_digit; /* Seen a digit after the decimal point? */ seen_dp = 0; seen_int_digit = 0; seen_dec_digit = 0; exponent_sign = 1; exponent = 0; w = f->u.w; /* Read in the next block. */ p = read_block_form (dtp, &w); if (p == NULL) return; p = eat_leading_spaces (&w, (char*) p); if (w == 0) goto zero; /* In this buffer we're going to re-format the number cleanly to be parsed by convert_real in the end; this assures we're using strtod from the C library for parsing and thus probably get the best accuracy possible. This process may add a '+0.0' in front of the number as well as change the exponent because of an implicit decimal point or the like. Thus allocating strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the original buffer had should be enough. */ buffer = gfc_alloca (w + 11); out = buffer; /* Optional sign */ if (*p == '-' || *p == '+') { if (*p == '-') *(out++) = '-'; ++p; --w; } p = eat_leading_spaces (&w, (char*) p); if (w == 0) goto zero; /* Process the mantissa string. */ while (w > 0) { switch (*p) { case ',': if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA) goto bad_float; /* Fall through. */ case '.': if (seen_dp) goto bad_float; if (!seen_int_digit) *(out++) = '0'; *(out++) = '.'; seen_dp = 1; break; case ' ': if (dtp->u.p.blank_status == BLANK_ZERO) { *(out++) = '0'; goto found_digit; } else if (dtp->u.p.blank_status == BLANK_NULL) break; else /* TODO: Should we check instead that there are only trailing blanks here, as is done below for exponents? */ goto done; /* Fall through. */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': *(out++) = *p; found_digit: if (!seen_dp) seen_int_digit = 1; else seen_dec_digit = 1; break; case '-': case '+': goto exponent; case 'e': case 'E': case 'd': case 'D': ++p; --w; goto exponent; default: goto bad_float; } ++p; --w; } /* No exponent has been seen, so we use the current scale factor. */ exponent = - dtp->u.p.scale_factor; goto done; /* At this point the start of an exponent has been found. */ exponent: p = eat_leading_spaces (&w, (char*) p); if (*p == '-' || *p == '+') { if (*p == '-') exponent_sign = -1; ++p; --w; } /* 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. */ if (w == 0) goto bad_float; if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) { while (w > 0 && isdigit (*p)) { exponent *= 10; exponent += *p - '0'; ++p; --w; } /* Only allow trailing blanks. */ while (w > 0) { if (*p != ' ') goto bad_float; ++p; --w; } } else /* BZ or BN status is enabled. */ { while (w > 0) { if (*p == ' ') { if (dtp->u.p.blank_status == BLANK_ZERO) exponent *= 10; else assert (dtp->u.p.blank_status == BLANK_NULL); } else if (!isdigit (*p)) goto bad_float; else { exponent *= 10; exponent += *p - '0'; } ++p; --w; } } exponent *= exponent_sign; done: /* Use the precision specified in the format if no decimal point has been seen. */ if (!seen_dp) exponent -= f->u.real.d; /* Output a trailing '0' after decimal point if not yet found. */ if (seen_dp && !seen_dec_digit) *(out++) = '0'; /* Print out the exponent to finish the reformatted number. Maximum 4 digits for the exponent. */ if (exponent != 0) { int dig; *(out++) = 'e'; if (exponent < 0) { *(out++) = '-'; exponent = - exponent; } assert (exponent < 10000); for (dig = 3; dig >= 0; --dig) { out[dig] = (char) ('0' + exponent % 10); exponent /= 10; } out += 4; } *(out++) = '\0'; /* Do the actual conversion. */ convert_real (dtp, dest, buffer, length); return; /* The value read is zero. */ zero: switch (length) { case 4: *((GFC_REAL_4 *) dest) = 0.0; break; case 8: *((GFC_REAL_8 *) dest) = 0.0; break; #ifdef HAVE_GFC_REAL_10 case 10: *((GFC_REAL_10 *) dest) = 0.0; break; #endif #ifdef HAVE_GFC_REAL_16 case 16: *((GFC_REAL_16 *) dest) = 0.0; break; #endif default: internal_error (&dtp->common, "Unsupported real kind during IO"); } return; bad_float: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during floating point read"); next_record (dtp, 1); return; }
void read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { GFC_UINTEGER_LARGEST value, maxv, maxv_10; GFC_INTEGER_LARGEST v; int w, negative; char c, *p; w = f->u.w; p = read_block_form (dtp, &w); if (p == NULL) return; p = eat_leading_spaces (&w, p); if (w == 0) { set_integer (dest, (GFC_INTEGER_LARGEST) 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 (dtp, &p, &w); if (c == '\0') break; if (c == ' ') { if (dtp->u.p.blank_status == BLANK_NULL) continue; if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; } if (c < '0' || c > '9') goto bad; if (value > maxv_10 && compile_options.range_check == 1) goto overflow; c -= '0'; value = 10 * value; if (value > maxv - c && compile_options.range_check == 1) goto overflow; value += c; } v = value; if (negative) v = -v; set_integer (dest, v, length); return; bad: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during integer read"); next_record (dtp, 1); return; overflow: generate_error (&dtp->common, LIBERROR_READ_OVERFLOW, "Value overflowed during integer read"); next_record (dtp, 1); }
void 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; int w, negative; char c, *p; w = f->u.w; p = read_block_form (dtp, &w); if (p == NULL) return; p = eat_leading_spaces (&w, p); if (w == 0) { set_integer (dest, (GFC_INTEGER_LARGEST) 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 (dtp, &p, &w); if (c == '\0') break; if (c == ' ') { if (dtp->u.p.blank_status == BLANK_NULL) continue; if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; } 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': case 'f': c = c - 'a' + '9' + 1; break; case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': 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 = value; if (negative) v = -v; set_integer (dest, v, length); return; bad: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during integer read"); next_record (dtp, 1); return; overflow: generate_error (&dtp->common, LIBERROR_READ_OVERFLOW, "Value overflowed during integer read"); next_record (dtp, 1); }
void read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { size_t wu; int w, seen_dp, exponent; int exponent_sign, val_sign; int ndigits; int edigits; int i; char *p, *buffer; char *digits; char scratch[SCRATCH_SIZE]; val_sign = 1; seen_dp = 0; wu = f->u.w; p = gfc_alloca (wu); if (read_block_form (dtp, p, &wu) == FAILURE) return; w = wu; p = eat_leading_spaces (&w, p); if (w == 0) goto zero; /* Optional sign */ if (*p == '-' || *p == '+') { if (*p == '-') val_sign = -1; p++; w--; } exponent_sign = 1; p = eat_leading_spaces (&w, p); if (w == 0) goto zero; /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D') is required at this point */ if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D' && *p != 'e' && *p != 'E') goto bad_float; /* Remember the position of the first digit. */ digits = p; ndigits = 0; /* Scan through the string to find the exponent. */ while (w > 0) { switch (*p) { case ',': if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA && *p == ',') *p = '.'; else goto bad_float; /* Fall through */ case '.': if (seen_dp) goto bad_float; seen_dp = 1; /* Fall through */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case ' ': ndigits++; 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 = -dtp->u.p.scale_factor; goto done; bad_float: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during floating point read"); next_record (dtp, 1); return; /* The value read is zero */ zero: switch (length) { case 4: *((GFC_REAL_4 *) dest) = 0; break; case 8: *((GFC_REAL_8 *) dest) = 0; break; #ifdef HAVE_GFC_REAL_10 case 10: *((GFC_REAL_10 *) dest) = 0; break; #endif #ifdef HAVE_GFC_REAL_16 case 16: *((GFC_REAL_16 *) dest) = 0; break; #endif default: internal_error (&dtp->common, "Unsupported real kind during IO"); } 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: /* Normal processing of exponent */ exponent = 0; if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) { while (w > 0 && isdigit (*p)) { exponent = 10 * exponent + *p - '0'; p++; w--; } /* Only allow trailing blanks */ while (w > 0) { if (*p != ' ') goto bad_float; p++; w--; } } else /* BZ or BN status is enabled */ { while (w > 0) { if (*p == ' ') { if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0'; if (dtp->u.p.blank_status == BLANK_NULL) { p++; w--; continue; } } else if (!isdigit (*p)) goto bad_float; exponent = 10 * exponent + *p - '0'; p++; w--; } } exponent = exponent * exponent_sign; done: /* Use the precision specified in the format if no decimal point has been seen. */ if (!seen_dp) exponent -= f->u.real.d; if (exponent > 0) { edigits = 2; i = exponent; } else { edigits = 3; i = -exponent; } while (i >= 10) { i /= 10; edigits++; } i = ndigits + edigits + 1; if (val_sign < 0) i++; if (i < SCRATCH_SIZE) buffer = scratch; else buffer = get_mem (i); /* Reformat the string into a temporary buffer. As we're using atof it's easiest to just leave the decimal point in place. */ p = buffer; if (val_sign < 0) *(p++) = '-'; for (; ndigits > 0; ndigits--) { if (*digits == ' ') { if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0'; if (dtp->u.p.blank_status == BLANK_NULL) { digits++; continue; } } *p = *digits; p++; digits++; } *(p++) = 'e'; sprintf (p, "%d", exponent); /* Do the actual conversion. */ convert_real (dtp, dest, buffer, length); if (buffer != scratch) free_mem (buffer); }