static void read_default_char4 (st_parameter_dt *dtp, char *p, int len, size_t width) { char *s; gfc_char4_t *dest; int m, n, status; s = gfc_alloca (width); status = read_block_form (dtp, s, &width); if (status == FAILURE) return; if (width > (size_t) len) s += (width - len); m = ((int) width > len) ? len : (int) width; dest = (gfc_char4_t *) p; for (n = 0; n < m; n++, dest++, s++) *dest = (unsigned char ) *s; for (n = 0; n < len - (int) width; n++, dest++) *dest = (unsigned char) ' '; }
static void read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width) { int m, n; gfc_char4_t *dest; if (is_char4_unit(dtp)) { gfc_char4_t *s4; s4 = (gfc_char4_t *) read_block_form4 (dtp, &width); if (s4 == NULL) return; if (width > len) s4 += (width - len); m = ((int) width > len) ? len : (int) width; dest = (gfc_char4_t *) p; for (n = 0; n < m; n++) *dest++ = *s4++; for (n = 0; n < len - (int) width; n++) *dest++ = (gfc_char4_t) ' '; } else { char *s; s = read_block_form (dtp, &width); if (s == NULL) return; if (width > len) s += (width - len); m = ((int) width > len) ? len : (int) width; dest = (gfc_char4_t *) p; for (n = 0; n < m; n++, dest++, s++) *dest = (unsigned char ) *s; for (n = 0; n < len - (int) width; n++, dest++) *dest = (unsigned char) ' '; } }
void read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { char *p; int w; w = f->u.w; p = read_block_form (dtp, &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, (GFC_INTEGER_LARGEST) 1, length); break; case 'f': case 'F': set_integer (dest, (GFC_INTEGER_LARGEST) 0, length); break; default: bad: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value on logical read"); next_record (dtp, 1); break; } }
static void read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width) { char *s; int m, n; s = read_block_form (dtp, &width); if (s == NULL) return; if (width > len) s += (width - len); m = (width > len) ? len : width; memcpy (p, s, m); n = len - width; if (n > 0) memset (p + m, ' ', n); }
static void read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width) { char *s; int m, n, status; s = gfc_alloca (width); status = read_block_form (dtp, s, &width); if (status == FAILURE) return; if (width > (size_t) len) s += (width - len); m = ((int) width > len) ? len : (int) width; memcpy (p, s, m); n = len - width; if (n > 0) memset (p + m, ' ', n); }
static void read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width) { char *s; gfc_char4_t *dest; int m, n; s = read_block_form (dtp, &width); if (s == NULL) return; if (width > len) s += (width - len); m = ((int) width > len) ? len : (int) width; dest = (gfc_char4_t *) p; for (n = 0; n < m; n++, dest++, s++) *dest = (unsigned char ) *s; for (n = 0; n < len - (int) width; n++, dest++) *dest = (unsigned char) ' '; }
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_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_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); }
static gfc_char4_t read_utf8 (st_parameter_dt *dtp, int *nbytes) { static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 }; static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; int i, nb, nread; gfc_char4_t c; char *s; *nbytes = 1; s = read_block_form (dtp, nbytes); if (s == NULL) return 0; /* If this is a short read, just return. */ if (*nbytes == 0) return 0; c = (uchar) s[0]; if (c < 0x80) return c; /* The number of leading 1-bits in the first byte indicates how many bytes follow. */ for (nb = 2; nb < 7; nb++) if ((c & ~masks[nb-1]) == patns[nb-1]) goto found; goto invalid; found: c = (c & masks[nb-1]); nread = nb - 1; s = read_block_form (dtp, &nread); if (s == NULL) return 0; /* Decode the bytes read. */ for (i = 1; i < nb; i++) { gfc_char4_t n = *s++; if ((n & 0xC0) != 0x80) goto invalid; c = ((c << 6) + (n & 0x3F)); } /* Make sure the shortest possible encoding was used. */ if (c <= 0x7F && nb > 1) goto invalid; if (c <= 0x7FF && nb > 2) goto invalid; if (c <= 0xFFFF && nb > 3) goto invalid; if (c <= 0x1FFFFF && nb > 4) goto invalid; if (c <= 0x3FFFFFF && nb > 5) goto invalid; /* Make sure the character is valid. */ if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF)) goto invalid; return c; invalid: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding"); return (gfc_char4_t) '?'; }
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); }