libgfortran/io/read.c

   1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010
   2    Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4    F2003 I/O support contributed by Jerry DeLisle
   5
   6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 Libgfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "io.h"
  28 #include "fbuf.h"
  29 #include "format.h"
  30 #include "unix.h"
  31 #include <string.h>
  32 #include <errno.h>
  33 #include <ctype.h>
  34 #include <stdlib.h>
  35 #include <assert.h>
  36
  37 typedef unsigned char uchar;
  38
  39 /* read.c -- Deal with formatted reads */
  40
  41
  42 /* set_integer()-- All of the integer assignments come here to
  43  * actually place the value into memory.  */
  44
  45 void
  46 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
  47 {
  48   switch (length)
  49     {
  50 #ifdef HAVE_GFC_INTEGER_16
  51 /* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
  52     case 10:
  53     case 16:
  54       {
  55         GFC_INTEGER_16 tmp = value;
  56         memcpy (dest, (void *) &tmp, length);
  57       }
  58       break;
  59 #endif
  60     case 8:
  61       {
  62         GFC_INTEGER_8 tmp = value;
  63         memcpy (dest, (void *) &tmp, length);
  64       }
  65       break;
  66     case 4:
  67       {
  68         GFC_INTEGER_4 tmp = value;
  69         memcpy (dest, (void *) &tmp, length);
  70       }
  71       break;
  72     case 2:
  73       {
  74         GFC_INTEGER_2 tmp = value;
  75         memcpy (dest, (void *) &tmp, length);
  76       }
  77       break;
  78     case 1:
  79       {
  80         GFC_INTEGER_1 tmp = value;
  81         memcpy (dest, (void *) &tmp, length);
  82       }
  83       break;
  84     default:
  85       internal_error (NULL, "Bad integer kind");
  86     }
  87 }
  88
  89
  90 /* max_value()-- Given a length (kind), return the maximum signed or
  91  * unsigned value */
  92
  93 GFC_UINTEGER_LARGEST
  94 max_value (int length, int signed_flag)
  95 {
  96   GFC_UINTEGER_LARGEST value;
  97 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
  98   int n;
  99 #endif
 100
 101   switch (length)
 102     {
 103 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
 104     case 16:
 105     case 10:
 106       value = 1;
 107       for (n = 1; n < 4 * length; n++)
 108         value = (value << 2) + 3;
 109       if (! signed_flag)
 110         value = 2*value+1;
 111       break;
 112 #endif
 113     case 8:
 114       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
 115       break;
 116     case 4:
 117       value = signed_flag ? 0x7fffffff : 0xffffffff;
 118       break;
 119     case 2:
 120       value = signed_flag ? 0x7fff : 0xffff;
 121       break;
 122     case 1:
 123       value = signed_flag ? 0x7f : 0xff;
 124       break;
 125     default:
 126       internal_error (NULL, "Bad integer kind");
 127     }
 128
 129   return value;
 130 }
 131
 132
 133 /* convert_real()-- Convert a character representation of a floating
 134  * point number to the machine number.  Returns nonzero if there is a
 135  * range problem during conversion.  Note: many architectures
 136  * (e.g. IA-64, HP-PA) require that the storage pointed to by the dest
 137  * argument is properly aligned for the type in question.  TODO:
 138  * handle not-a-numbers and infinities.  */
 139
 140 int
 141 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
 142 {
 143   errno = 0;
 144
 145   switch (length)
 146     {
 147     case 4:
 148       *((GFC_REAL_4*) dest) =
 149 #if defined(HAVE_STRTOF)
 150         gfc_strtof (buffer, NULL);
 151 #else
 152         (GFC_REAL_4) gfc_strtod (buffer, NULL);
 153 #endif
 154       break;
 155
 156     case 8:
 157       *((GFC_REAL_8*) dest) = gfc_strtod (buffer, NULL);
 158       break;
 159
 160 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
 161     case 10:
 162       *((GFC_REAL_10*) dest) = gfc_strtold (buffer, NULL);
 163       break;
 164 #endif
 165
 166 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
 167     case 16:
 168       *((GFC_REAL_16*) dest) = gfc_strtold (buffer, NULL);
 169       break;
 170 #endif
 171
 172     default:
 173       internal_error (&dtp->common, "Unsupported real kind during IO");
 174     }
 175
 176   if (errno == EINVAL)
 177     {
 178       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 179                       "Error during floating point read");
 180       next_record (dtp, 1);
 181       return 1;
 182     }
 183
 184   return 0;
 185 }
 186
 187
 188 /* read_l()-- Read a logical value */
 189
 190 void
 191 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 192 {
 193   char *p;
 194   int w;
 195
 196   w = f->u.w;
 197
 198   p = read_block_form (dtp, &w);
 199
 200   if (p == NULL)
 201     return;
 202
 203   while (*p == ' ')
 204     {
 205       if (--w == 0)
 206         goto bad;
 207       p++;
 208     }
 209
 210   if (*p == '.')
 211     {
 212       if (--w == 0)
 213         goto bad;
 214       p++;
 215     }
 216
 217   switch (*p)
 218     {
 219     case 't':
 220     case 'T':
 221       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
 222       break;
 223     case 'f':
 224     case 'F':
 225       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 226       break;
 227     default:
 228     bad:
 229       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 230                       "Bad value on logical read");
 231       next_record (dtp, 1);
 232       break;
 233     }
 234 }
 235
 236
 237 static gfc_char4_t
 238 read_utf8 (st_parameter_dt *dtp, int *nbytes)
 239 {
 240   static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
 241   static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
 242   int i, nb, nread;
 243   gfc_char4_t c;
 244   char *s;
 245
 246   *nbytes = 1;
 247
 248   s = read_block_form (dtp, nbytes);
 249   if (s == NULL)
 250     return 0;
 251
 252   /* If this is a short read, just return.  */
 253   if (*nbytes == 0)
 254     return 0;
 255
 256   c = (uchar) s[0];
 257   if (c < 0x80)
 258     return c;
 259
 260   /* The number of leading 1-bits in the first byte indicates how many
 261      bytes follow.  */
 262   for (nb = 2; nb < 7; nb++)
 263     if ((c & ~masks[nb-1]) == patns[nb-1])
 264       goto found;
 265   goto invalid;
 266
 267  found:
 268   c = (c & masks[nb-1]);
 269   nread = nb - 1;
 270
 271   s = read_block_form (dtp, &nread);
 272   if (s == NULL)
 273     return 0;
 274   /* Decode the bytes read.  */
 275   for (i = 1; i < nb; i++)
 276     {
 277       gfc_char4_t n = *s++;
 278
 279       if ((n & 0xC0) != 0x80)
 280         goto invalid;
 281
 282       c = ((c << 6) + (n & 0x3F));
 283     }
 284
 285   /* Make sure the shortest possible encoding was used.  */
 286   if (c <=      0x7F && nb > 1) goto invalid;
 287   if (c <=     0x7FF && nb > 2) goto invalid;
 288   if (c <=    0xFFFF && nb > 3) goto invalid;
 289   if (c <=  0x1FFFFF && nb > 4) goto invalid;
 290   if (c <= 0x3FFFFFF && nb > 5) goto invalid;
 291
 292   /* Make sure the character is valid.  */
 293   if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
 294     goto invalid;
 295
 296   return c;
 297
 298  invalid:
 299   generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
 300   return (gfc_char4_t) '?';
 301 }
 302
 303
 304 static void
 305 read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 306 {
 307   gfc_char4_t c;
 308   char *dest;
 309   int nbytes;
 310   int i, j;
 311
 312   len = (width < len) ? len : width;
 313
 314   dest = (char *) p;
 315
 316   /* Proceed with decoding one character at a time.  */
 317   for (j = 0; j < len; j++, dest++)
 318     {
 319       c = read_utf8 (dtp, &nbytes);
 320
 321       /* Check for a short read and if so, break out.  */
 322       if (nbytes == 0)
 323         break;
 324
 325       *dest = c > 255 ? '?' : (uchar) c;
 326     }
 327
 328   /* If there was a short read, pad the remaining characters.  */
 329   for (i = j; i < len; i++)
 330     *dest++ = ' ';
 331   return;
 332 }
 333
 334 static void
 335 read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 336 {
 337   char *s;
 338   int m, n;
 339
 340   s = read_block_form (dtp, &width);
 341
 342   if (s == NULL)
 343     return;
 344   if (width > len)
 345      s += (width - len);
 346
 347   m = (width > len) ? len : width;
 348   memcpy (p, s, m);
 349
 350   n = len - width;
 351   if (n > 0)
 352     memset (p + m, ' ', n);
 353 }
 354
 355
 356 static void
 357 read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
 358 {
 359   gfc_char4_t *dest;
 360   int nbytes;
 361   int i, j;
 362
 363   len = (width < len) ? len : width;
 364
 365   dest = (gfc_char4_t *) p;
 366
 367   /* Proceed with decoding one character at a time.  */
 368   for (j = 0; j < len; j++, dest++)
 369     {
 370       *dest = read_utf8 (dtp, &nbytes);
 371
 372       /* Check for a short read and if so, break out.  */
 373       if (nbytes == 0)
 374         break;
 375     }
 376
 377   /* If there was a short read, pad the remaining characters.  */
 378   for (i = j; i < len; i++)
 379     *dest++ = (gfc_char4_t) ' ';
 380   return;
 381 }
 382
 383
 384 static void
 385 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 386 {
 387   char *s;
 388   gfc_char4_t *dest;
 389   int m, n;
 390
 391   s = read_block_form (dtp, &width);
 392
 393   if (s == NULL)
 394     return;
 395   if (width > len)
 396      s += (width - len);
 397
 398   m = ((int) width > len) ? len : (int) width;
 399
 400   dest = (gfc_char4_t *) p;
 401
 402   for (n = 0; n < m; n++, dest++, s++)
 403     *dest = (unsigned char ) *s;
 404
 405   for (n = 0; n < len - (int) width; n++, dest++)
 406     *dest = (unsigned char) ' ';
 407 }
 408
 409
 410 /* read_a()-- Read a character record into a KIND=1 character destination,
 411    processing UTF-8 encoding if necessary.  */
 412
 413 void
 414 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 415 {
 416   int wi;
 417   int w;
 418
 419   wi = f->u.w;
 420   if (wi == -1) /* '(A)' edit descriptor  */
 421     wi = length;
 422   w = wi;
 423
 424   /* Read in w characters, treating comma as not a separator.  */
 425   dtp->u.p.sf_read_comma = 0;
 426
 427   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 428     read_utf8_char1 (dtp, p, length, w);
 429   else
 430     read_default_char1 (dtp, p, length, w);
 431
 432   dtp->u.p.sf_read_comma =
 433     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 434 }
 435
 436
 437 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
 438    processing UTF-8 encoding if necessary.  */
 439
 440 void
 441 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 442 {
 443   int w;
 444
 445   w = f->u.w;
 446   if (w == -1) /* '(A)' edit descriptor  */
 447     w = length;
 448
 449   /* Read in w characters, treating comma as not a separator.  */
 450   dtp->u.p.sf_read_comma = 0;
 451
 452   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 453     read_utf8_char4 (dtp, p, length, w);
 454   else
 455     read_default_char4 (dtp, p, length, w);
 456
 457   dtp->u.p.sf_read_comma =
 458     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 459 }
 460
 461 /* eat_leading_spaces()-- Given a character pointer and a width,
 462  * ignore the leading spaces.  */
 463
 464 static char *
 465 eat_leading_spaces (int *width, char *p)
 466 {
 467   for (;;)
 468     {
 469       if (*width == 0 || *p != ' ')
 470         break;
 471
 472       (*width)--;
 473       p++;
 474     }
 475
 476   return p;
 477 }
 478
 479
 480 static char
 481 next_char (st_parameter_dt *dtp, char **p, int *w)
 482 {
 483   char c, *q;
 484
 485   if (*w == 0)
 486     return '\0';
 487
 488   q = *p;
 489   c = *q++;
 490   *p = q;
 491
 492   (*w)--;
 493
 494   if (c != ' ')
 495     return c;
 496   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
 497     return ' ';  /* return a blank to signal a null */
 498
 499   /* At this point, the rest of the field has to be trailing blanks */
 500
 501   while (*w > 0)
 502     {
 503       if (*q++ != ' ')
 504         return '?';
 505       (*w)--;
 506     }
 507
 508   *p = q;
 509   return '\0';
 510 }
 511
 512
 513 /* read_decimal()-- Read a decimal integer value.  The values here are
 514  * signed values. */
 515
 516 void
 517 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 518 {
 519   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 520   GFC_INTEGER_LARGEST v;
 521   int w, negative;
 522   char c, *p;
 523
 524   w = f->u.w;
 525
 526   p = read_block_form (dtp, &w);
 527
 528   if (p == NULL)
 529     return;
 530
 531   p = eat_leading_spaces (&w, p);
 532   if (w == 0)
 533     {
 534       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 535       return;
 536     }
 537
 538   maxv = max_value (length, 1);
 539   maxv_10 = maxv / 10;
 540
 541   negative = 0;
 542   value = 0;
 543
 544   switch (*p)
 545     {
 546     case '-':
 547       negative = 1;
 548       /* Fall through */
 549
 550     case '+':
 551       p++;
 552       if (--w == 0)
 553         goto bad;
 554       /* Fall through */
 555
 556     default:
 557       break;
 558     }
 559
 560   /* At this point we have a digit-string */
 561   value = 0;
 562
 563   for (;;)
 564     {
 565       c = next_char (dtp, &p, &w);
 566       if (c == '\0')
 567         break;
 568
 569       if (c == ' ')
 570         {
 571           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 572           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 573         }
 574
 575       if (c < '0' || c > '9')
 576         goto bad;
 577
 578       if (value > maxv_10 && compile_options.range_check == 1)
 579         goto overflow;
 580
 581       c -= '0';
 582       value = 10 * value;
 583
 584       if (value > maxv - c && compile_options.range_check == 1)
 585         goto overflow;
 586       value += c;
 587     }
 588
 589   v = value;
 590   if (negative)
 591     v = -v;
 592
 593   set_integer (dest, v, length);
 594   return;
 595
 596  bad:
 597   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 598                   "Bad value during integer read");
 599   next_record (dtp, 1);
 600   return;
 601
 602  overflow:
 603   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 604                   "Value overflowed during integer read");
 605   next_record (dtp, 1);
 606
 607 }
 608
 609
 610 /* read_radix()-- This function reads values for non-decimal radixes.
 611  * The difference here is that we treat the values here as unsigned
 612  * values for the purposes of overflow.  If minus sign is present and
 613  * the top bit is set, the value will be incorrect. */
 614
 615 void
 616 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 617             int radix)
 618 {
 619   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 620   GFC_INTEGER_LARGEST v;
 621   int w, negative;
 622   char c, *p;
 623
 624   w = f->u.w;
 625
 626   p = read_block_form (dtp, &w);
 627
 628   if (p == NULL)
 629     return;
 630
 631   p = eat_leading_spaces (&w, p);
 632   if (w == 0)
 633     {
 634       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 635       return;
 636     }
 637
 638   maxv = max_value (length, 0);
 639   maxv_r = maxv / radix;
 640
 641   negative = 0;
 642   value = 0;
 643
 644   switch (*p)
 645     {
 646     case '-':
 647       negative = 1;
 648       /* Fall through */
 649
 650     case '+':
 651       p++;
 652       if (--w == 0)
 653         goto bad;
 654       /* Fall through */
 655
 656     default:
 657       break;
 658     }
 659
 660   /* At this point we have a digit-string */
 661   value = 0;
 662
 663   for (;;)
 664     {
 665       c = next_char (dtp, &p, &w);
 666       if (c == '\0')
 667         break;
 668       if (c == ' ')
 669         {
 670           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 671           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 672         }
 673
 674       switch (radix)
 675         {
 676         case 2:
 677           if (c < '0' || c > '1')
 678             goto bad;
 679           break;
 680
 681         case 8:
 682           if (c < '0' || c > '7')
 683             goto bad;
 684           break;
 685
 686         case 16:
 687           switch (c)
 688             {
 689             case '0':
 690             case '1':
 691             case '2':
 692             case '3':
 693             case '4':
 694             case '5':
 695             case '6':
 696             case '7':
 697             case '8':
 698             case '9':
 699               break;
 700
 701             case 'a':
 702             case 'b':
 703             case 'c':
 704             case 'd':
 705             case 'e':
 706             case 'f':
 707               c = c - 'a' + '9' + 1;
 708               break;
 709
 710             case 'A':
 711             case 'B':
 712             case 'C':
 713             case 'D':
 714             case 'E':
 715             case 'F':
 716               c = c - 'A' + '9' + 1;
 717               break;
 718
 719             default:
 720               goto bad;
 721             }
 722
 723           break;
 724         }
 725
 726       if (value > maxv_r)
 727         goto overflow;
 728
 729       c -= '0';
 730       value = radix * value;
 731
 732       if (maxv - c < value)
 733         goto overflow;
 734       value += c;
 735     }
 736
 737   v = value;
 738   if (negative)
 739     v = -v;
 740
 741   set_integer (dest, v, length);
 742   return;
 743
 744  bad:
 745   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 746                   "Bad value during integer read");
 747   next_record (dtp, 1);
 748   return;
 749
 750  overflow:
 751   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 752                   "Value overflowed during integer read");
 753   next_record (dtp, 1);
 754
 755 }
 756
 757
 758 /* read_f()-- Read a floating point number with F-style editing, which
 759    is what all of the other floating point descriptors behave as.  The
 760    tricky part is that optional spaces are allowed after an E or D,
 761    and the implicit decimal point if a decimal point is not present in
 762    the input.  */
 763
 764 void
 765 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 766 {
 767   int w, seen_dp, exponent;
 768   int exponent_sign;
 769   const char *p;
 770   char *buffer;
 771   char *out;
 772   int seen_int_digit; /* Seen a digit before the decimal point?  */
 773   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 774
 775   seen_dp = 0;
 776   seen_int_digit = 0;
 777   seen_dec_digit = 0;
 778   exponent_sign = 1;
 779   exponent = 0;
 780   w = f->u.w;
 781
 782   /* Read in the next block.  */
 783   p = read_block_form (dtp, &w);
 784   if (p == NULL)
 785     return;
 786   p = eat_leading_spaces (&w, (char*) p);
 787   if (w == 0)
 788     goto zero;
 789
 790   /* In this buffer we're going to re-format the number cleanly to be parsed
 791      by convert_real in the end; this assures we're using strtod from the
 792      C library for parsing and thus probably get the best accuracy possible.
 793      This process may add a '+0.0' in front of the number as well as change the
 794      exponent because of an implicit decimal point or the like.  Thus allocating
 795      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 796      original buffer had should be enough.  */
 797   buffer = gfc_alloca (w + 11);
 798   out = buffer;
 799
 800   /* Optional sign */
 801   if (*p == '-' || *p == '+')
 802     {
 803       if (*p == '-')
 804         *(out++) = '-';
 805       ++p;
 806       --w;
 807     }
 808
 809   p = eat_leading_spaces (&w, (char*) p);
 810   if (w == 0)
 811     goto zero;
 812
 813   /* Process the mantissa string.  */
 814   while (w > 0)
 815     {
 816       switch (*p)
 817         {
 818         case ',':
 819           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 820             goto bad_float;
 821           /* Fall through.  */
 822         case '.':
 823           if (seen_dp)
 824             goto bad_float;
 825           if (!seen_int_digit)
 826             *(out++) = '0';
 827           *(out++) = '.';
 828           seen_dp = 1;
 829           break;
 830
 831         case ' ':
 832           if (dtp->u.p.blank_status == BLANK_ZERO)
 833             {
 834               *(out++) = '0';
 835               goto found_digit;
 836             }
 837           else if (dtp->u.p.blank_status == BLANK_NULL)
 838             break;
 839           else
 840             /* TODO: Should we check instead that there are only trailing
 841                blanks here, as is done below for exponents?  */
 842             goto done;
 843           /* Fall through.  */
 844         case '0':
 845         case '1':
 846         case '2':
 847         case '3':
 848         case '4':
 849         case '5':
 850         case '6':
 851         case '7':
 852         case '8':
 853         case '9':
 854           *(out++) = *p;
 855 found_digit:
 856           if (!seen_dp)
 857             seen_int_digit = 1;
 858           else
 859             seen_dec_digit = 1;
 860           break;
 861
 862         case '-':
 863         case '+':
 864           goto exponent;
 865
 866         case 'e':
 867         case 'E':
 868         case 'd':
 869         case 'D':
 870           ++p;
 871           --w;
 872           goto exponent;
 873
 874         default:
 875           goto bad_float;
 876         }
 877
 878       ++p;
 879       --w;
 880     }
 881
 882   /* No exponent has been seen, so we use the current scale factor.  */
 883   exponent = - dtp->u.p.scale_factor;
 884   goto done;
 885
 886   /* At this point the start of an exponent has been found.  */
 887 exponent:
 888   p = eat_leading_spaces (&w, (char*) p);
 889   if (*p == '-' || *p == '+')
 890     {
 891       if (*p == '-')
 892         exponent_sign = -1;
 893       ++p;
 894       --w;
 895     }
 896
 897   /* At this point a digit string is required.  We calculate the value
 898      of the exponent in order to take account of the scale factor and
 899      the d parameter before explict conversion takes place.  */
 900
 901   if (w == 0)
 902     goto bad_float;
 903
 904   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
 905     {
 906       while (w > 0 && isdigit (*p))
 907         {
 908           exponent *= 10;
 909           exponent += *p - '0';
 910           ++p;
 911           --w;
 912         }
 913
 914       /* Only allow trailing blanks.  */
 915       while (w > 0)
 916         {
 917           if (*p != ' ')
 918             goto bad_float;
 919           ++p;
 920           --w;
 921         }
 922     }
 923   else  /* BZ or BN status is enabled.  */
 924     {
 925       while (w > 0)
 926         {
 927           if (*p == ' ')
 928             {
 929               if (dtp->u.p.blank_status == BLANK_ZERO)
 930                 exponent *= 10;
 931               else
 932                 assert (dtp->u.p.blank_status == BLANK_NULL);
 933             }
 934           else if (!isdigit (*p))
 935             goto bad_float;
 936           else
 937             {
 938               exponent *= 10;
 939               exponent += *p - '0';
 940             }
 941
 942           ++p;
 943           --w;
 944         }
 945     }
 946
 947   exponent *= exponent_sign;
 948
 949 done:
 950   /* Use the precision specified in the format if no decimal point has been
 951      seen.  */
 952   if (!seen_dp)
 953     exponent -= f->u.real.d;
 954
 955   /* Output a trailing '0' after decimal point if not yet found.  */
 956   if (seen_dp && !seen_dec_digit)
 957     *(out++) = '0';
 958
 959   /* Print out the exponent to finish the reformatted number.  Maximum 4
 960      digits for the exponent.  */
 961   if (exponent != 0)
 962     {
 963       int dig;
 964
 965       *(out++) = 'e';
 966       if (exponent < 0)
 967         {
 968           *(out++) = '-';
 969           exponent = - exponent;
 970         }
 971
 972       assert (exponent < 10000);
 973       for (dig = 3; dig >= 0; --dig)
 974         {
 975           out[dig] = (char) ('0' + exponent % 10);
 976           exponent /= 10;
 977         }
 978       out += 4;
 979     }
 980   *(out++) = '\0';
 981
 982   /* Do the actual conversion.  */
 983   convert_real (dtp, dest, buffer, length);
 984
 985   return;
 986
 987   /* The value read is zero.  */
 988 zero:
 989   switch (length)
 990     {
 991       case 4:
 992         *((GFC_REAL_4 *) dest) = 0.0;
 993         break;
 994
 995       case 8:
 996         *((GFC_REAL_8 *) dest) = 0.0;
 997         break;
 998
 999 #ifdef HAVE_GFC_REAL_10
1000       case 10:
1001         *((GFC_REAL_10 *) dest) = 0.0;
1002         break;
1003 #endif
1004
1005 #ifdef HAVE_GFC_REAL_16
1006       case 16:
1007         *((GFC_REAL_16 *) dest) = 0.0;
1008         break;
1009 #endif
1010
1011       default:
1012         internal_error (&dtp->common, "Unsupported real kind during IO");
1013     }
1014   return;
1015
1016 bad_float:
1017   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1018                   "Bad value during floating point read");
1019   next_record (dtp, 1);
1020   return;
1021 }
1022
1023
1024 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1025  * and never look at it. */
1026
1027 void
1028 read_x (st_parameter_dt *dtp, int n)
1029 {
1030   int length;
1031   char *p, q;
1032
1033   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1034        && dtp->u.p.current_unit->bytes_left < n)
1035     n = dtp->u.p.current_unit->bytes_left;
1036
1037   if (n == 0)
1038     return;
1039
1040   length = n;
1041
1042   if (is_internal_unit (dtp))
1043     {
1044       p = mem_alloc_r (dtp->u.p.current_unit->s, &length);
1045       if (unlikely (length < n))
1046         n = length;
1047       goto done;
1048     }
1049
1050   if (dtp->u.p.sf_seen_eor)
1051     return;
1052
1053   p = fbuf_read (dtp->u.p.current_unit, &length);
1054   if (p == NULL)
1055     {
1056       hit_eof (dtp);
1057       return;
1058     }
1059
1060   if (length == 0 && dtp->u.p.item_count == 1)
1061     {
1062       if (dtp->u.p.current_unit->pad_status == PAD_NO)
1063         {
1064           hit_eof (dtp);
1065           return;
1066         }
1067       else
1068         return;
1069     }
1070
1071   n = 0;
1072   while (n < length)
1073     {
1074       q = *p;
1075       if (q == '\n' || q == '\r')
1076         {
1077           /* Unexpected end of line. Set the position.  */
1078           fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
1079           dtp->u.p.sf_seen_eor = 1;
1080
1081           /* If we encounter a CR, it might be a CRLF.  */
1082           if (q == '\r') /* Probably a CRLF */
1083             {
1084               /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
1085                  the position is not advanced unless it really is an LF.  */
1086               int readlen = 1;
1087               p = fbuf_read (dtp->u.p.current_unit, &readlen);
1088               if (*p == '\n' && readlen == 1)
1089                 {
1090                   dtp->u.p.sf_seen_eor = 2;
1091                   fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
1092                 }
1093             }
1094           goto done;
1095         }
1096       n++;
1097       p++;
1098     }
1099
1100   fbuf_seek (dtp->u.p.current_unit, n, SEEK_CUR);
1101
1102  done:
1103   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1104     dtp->u.p.size_used += (GFC_IO_INT) n;
1105   dtp->u.p.current_unit->bytes_left -= n;
1106   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1107 }
1108