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   /* Check for Infinity or NaN.  */
 814   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 815     {
 816       int seen_paren = 0;
 817       char *save = out;
 818
 819       /* Scan through the buffer keeping track of spaces and parenthesis. We
 820          null terminate the string as soon as we see a left paren or if we are
 821          BLANK_NULL mode.  Leading spaces have already been skipped above,
 822          trailing spaces are ignored by converting to '\0'. A space
 823          between "NaN" and the optional perenthesis is not permitted.  */
 824       while (w > 0)
 825         {
 826           *out = tolower (*p);
 827           switch (*p)
 828             {
 829             case ' ':
 830               if (dtp->u.p.blank_status == BLANK_ZERO)
 831                 {
 832                   *out = '0';
 833                   break;
 834                 }
 835               *out = '\0';
 836               if (seen_paren == 1)
 837                 goto bad_float;
 838               break;
 839             case '(':
 840               seen_paren++;
 841               *out = '\0';
 842               break;
 843             case ')':
 844               if (seen_paren++ != 1)
 845                 goto bad_float;
 846               break;
 847             default:
 848               if (!isalnum (*out))
 849                 goto bad_float;
 850             }
 851           --w;
 852           ++p;
 853           ++out;
 854         }
 855
 856       *out = '\0';
 857
 858       if (seen_paren != 0 && seen_paren != 2)
 859         goto bad_float;
 860
 861       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 862         {
 863            if (seen_paren)
 864              goto bad_float;
 865         }
 866       else if (strcmp (save, "nan") != 0)
 867         goto bad_float;
 868
 869       convert_real (dtp, dest, buffer, length);
 870       return;
 871     }
 872
 873   /* Process the mantissa string.  */
 874   while (w > 0)
 875     {
 876       switch (*p)
 877         {
 878         case ',':
 879           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 880             goto bad_float;
 881           /* Fall through.  */
 882         case '.':
 883           if (seen_dp)
 884             goto bad_float;
 885           if (!seen_int_digit)
 886             *(out++) = '0';
 887           *(out++) = '.';
 888           seen_dp = 1;
 889           break;
 890
 891         case ' ':
 892           if (dtp->u.p.blank_status == BLANK_ZERO)
 893             {
 894               *(out++) = '0';
 895               goto found_digit;
 896             }
 897           else if (dtp->u.p.blank_status == BLANK_NULL)
 898             break;
 899           else
 900             /* TODO: Should we check instead that there are only trailing
 901                blanks here, as is done below for exponents?  */
 902             goto done;
 903           /* Fall through.  */
 904         case '0':
 905         case '1':
 906         case '2':
 907         case '3':
 908         case '4':
 909         case '5':
 910         case '6':
 911         case '7':
 912         case '8':
 913         case '9':
 914           *(out++) = *p;
 915 found_digit:
 916           if (!seen_dp)
 917             seen_int_digit = 1;
 918           else
 919             seen_dec_digit = 1;
 920           break;
 921
 922         case '-':
 923         case '+':
 924           goto exponent;
 925
 926         case 'e':
 927         case 'E':
 928         case 'd':
 929         case 'D':
 930           ++p;
 931           --w;
 932           goto exponent;
 933
 934         default:
 935           goto bad_float;
 936         }
 937
 938       ++p;
 939       --w;
 940     }
 941
 942   /* No exponent has been seen, so we use the current scale factor.  */
 943   exponent = - dtp->u.p.scale_factor;
 944   goto done;
 945
 946   /* At this point the start of an exponent has been found.  */
 947 exponent:
 948   p = eat_leading_spaces (&w, (char*) p);
 949   if (*p == '-' || *p == '+')
 950     {
 951       if (*p == '-')
 952         exponent_sign = -1;
 953       ++p;
 954       --w;
 955     }
 956
 957   /* At this point a digit string is required.  We calculate the value
 958      of the exponent in order to take account of the scale factor and
 959      the d parameter before explict conversion takes place.  */
 960
 961   if (w == 0)
 962     goto bad_float;
 963
 964   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
 965     {
 966       while (w > 0 && isdigit (*p))
 967         {
 968           exponent *= 10;
 969           exponent += *p - '0';
 970           ++p;
 971           --w;
 972         }
 973
 974       /* Only allow trailing blanks.  */
 975       while (w > 0)
 976         {
 977           if (*p != ' ')
 978             goto bad_float;
 979           ++p;
 980           --w;
 981         }
 982     }
 983   else  /* BZ or BN status is enabled.  */
 984     {
 985       while (w > 0)
 986         {
 987           if (*p == ' ')
 988             {
 989               if (dtp->u.p.blank_status == BLANK_ZERO)
 990                 exponent *= 10;
 991               else
 992                 assert (dtp->u.p.blank_status == BLANK_NULL);
 993             }
 994           else if (!isdigit (*p))
 995             goto bad_float;
 996           else
 997             {
 998               exponent *= 10;
 999               exponent += *p - '0';
1000             }
1001
1002           ++p;
1003           --w;
1004         }
1005     }
1006
1007   exponent *= exponent_sign;
1008
1009 done:
1010   /* Use the precision specified in the format if no decimal point has been
1011      seen.  */
1012   if (!seen_dp)
1013     exponent -= f->u.real.d;
1014
1015   /* Output a trailing '0' after decimal point if not yet found.  */
1016   if (seen_dp && !seen_dec_digit)
1017     *(out++) = '0';
1018
1019   /* Print out the exponent to finish the reformatted number.  Maximum 4
1020      digits for the exponent.  */
1021   if (exponent != 0)
1022     {
1023       int dig;
1024
1025       *(out++) = 'e';
1026       if (exponent < 0)
1027         {
1028           *(out++) = '-';
1029           exponent = - exponent;
1030         }
1031
1032       assert (exponent < 10000);
1033       for (dig = 3; dig >= 0; --dig)
1034         {
1035           out[dig] = (char) ('0' + exponent % 10);
1036           exponent /= 10;
1037         }
1038       out += 4;
1039     }
1040   *(out++) = '\0';
1041
1042   /* Do the actual conversion.  */
1043   convert_real (dtp, dest, buffer, length);
1044
1045   return;
1046
1047   /* The value read is zero.  */
1048 zero:
1049   switch (length)
1050     {
1051       case 4:
1052         *((GFC_REAL_4 *) dest) = 0.0;
1053         break;
1054
1055       case 8:
1056         *((GFC_REAL_8 *) dest) = 0.0;
1057         break;
1058
1059 #ifdef HAVE_GFC_REAL_10
1060       case 10:
1061         *((GFC_REAL_10 *) dest) = 0.0;
1062         break;
1063 #endif
1064
1065 #ifdef HAVE_GFC_REAL_16
1066       case 16:
1067         *((GFC_REAL_16 *) dest) = 0.0;
1068         break;
1069 #endif
1070
1071       default:
1072         internal_error (&dtp->common, "Unsupported real kind during IO");
1073     }
1074   return;
1075
1076 bad_float:
1077   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1078                   "Bad value during floating point read");
1079   next_record (dtp, 1);
1080   return;
1081 }
1082
1083
1084 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1085  * and never look at it. */
1086
1087 void
1088 read_x (st_parameter_dt *dtp, int n)
1089 {
1090   int length;
1091   char *p, q;
1092
1093   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1094        && dtp->u.p.current_unit->bytes_left < n)
1095     n = dtp->u.p.current_unit->bytes_left;
1096
1097   if (n == 0)
1098     return;
1099
1100   length = n;
1101
1102   if (is_internal_unit (dtp))
1103     {
1104       p = mem_alloc_r (dtp->u.p.current_unit->s, &length);
1105       if (unlikely (length < n))
1106         n = length;
1107       goto done;
1108     }
1109
1110   if (dtp->u.p.sf_seen_eor)
1111     return;
1112
1113   p = fbuf_read (dtp->u.p.current_unit, &length);
1114   if (p == NULL)
1115     {
1116       hit_eof (dtp);
1117       return;
1118     }
1119
1120   if (length == 0 && dtp->u.p.item_count == 1)
1121     {
1122       if (dtp->u.p.current_unit->pad_status == PAD_NO)
1123         {
1124           hit_eof (dtp);
1125           return;
1126         }
1127       else
1128         return;
1129     }
1130
1131   n = 0;
1132   while (n < length)
1133     {
1134       q = *p;
1135       if (q == '\n' || q == '\r')
1136         {
1137           /* Unexpected end of line. Set the position.  */
1138           fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
1139           dtp->u.p.sf_seen_eor = 1;
1140
1141           /* If we encounter a CR, it might be a CRLF.  */
1142           if (q == '\r') /* Probably a CRLF */
1143             {
1144               /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
1145                  the position is not advanced unless it really is an LF.  */
1146               int readlen = 1;
1147               p = fbuf_read (dtp->u.p.current_unit, &readlen);
1148               if (*p == '\n' && readlen == 1)
1149                 {
1150                   dtp->u.p.sf_seen_eor = 2;
1151                   fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
1152                 }
1153             }
1154           goto done;
1155         }
1156       n++;
1157       p++;
1158     }
1159
1160   fbuf_seek (dtp->u.p.current_unit, n, SEEK_CUR);
1161
1162  done:
1163   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1164     dtp->u.p.size_used += (GFC_IO_INT) n;
1165   dtp->u.p.current_unit->bytes_left -= n;
1166   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1167 }
1168