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.  */
 138
 139 int
 140 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
 141 {
 142   errno = 0;
 143
 144   switch (length)
 145     {
 146     case 4:
 147       *((GFC_REAL_4*) dest) =
 148 #if defined(HAVE_STRTOF)
 149         gfc_strtof (buffer, NULL);
 150 #else
 151         (GFC_REAL_4) gfc_strtod (buffer, NULL);
 152 #endif
 153       break;
 154
 155     case 8:
 156       *((GFC_REAL_8*) dest) = gfc_strtod (buffer, NULL);
 157       break;
 158
 159 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
 160     case 10:
 161       *((GFC_REAL_10*) dest) = gfc_strtold (buffer, NULL);
 162       break;
 163 #endif
 164
 165 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
 166     case 16:
 167       *((GFC_REAL_16*) dest) = gfc_strtold (buffer, NULL);
 168       break;
 169 #endif
 170
 171     default:
 172       internal_error (&dtp->common, "Unsupported real kind during IO");
 173     }
 174
 175   if (errno == EINVAL)
 176     {
 177       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 178                       "Error during floating point read");
 179       next_record (dtp, 1);
 180       return 1;
 181     }
 182
 183   return 0;
 184 }
 185
 186
 187 /* read_l()-- Read a logical value */
 188
 189 void
 190 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 191 {
 192   char *p;
 193   int w;
 194
 195   w = f->u.w;
 196
 197   p = read_block_form (dtp, &w);
 198
 199   if (p == NULL)
 200     return;
 201
 202   while (*p == ' ')
 203     {
 204       if (--w == 0)
 205         goto bad;
 206       p++;
 207     }
 208
 209   if (*p == '.')
 210     {
 211       if (--w == 0)
 212         goto bad;
 213       p++;
 214     }
 215
 216   switch (*p)
 217     {
 218     case 't':
 219     case 'T':
 220       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
 221       break;
 222     case 'f':
 223     case 'F':
 224       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 225       break;
 226     default:
 227     bad:
 228       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 229                       "Bad value on logical read");
 230       next_record (dtp, 1);
 231       break;
 232     }
 233 }
 234
 235
 236 static gfc_char4_t
 237 read_utf8 (st_parameter_dt *dtp, int *nbytes)
 238 {
 239   static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
 240   static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
 241   int i, nb, nread;
 242   gfc_char4_t c;
 243   char *s;
 244
 245   *nbytes = 1;
 246
 247   s = read_block_form (dtp, nbytes);
 248   if (s == NULL)
 249     return 0;
 250
 251   /* If this is a short read, just return.  */
 252   if (*nbytes == 0)
 253     return 0;
 254
 255   c = (uchar) s[0];
 256   if (c < 0x80)
 257     return c;
 258
 259   /* The number of leading 1-bits in the first byte indicates how many
 260      bytes follow.  */
 261   for (nb = 2; nb < 7; nb++)
 262     if ((c & ~masks[nb-1]) == patns[nb-1])
 263       goto found;
 264   goto invalid;
 265
 266  found:
 267   c = (c & masks[nb-1]);
 268   nread = nb - 1;
 269
 270   s = read_block_form (dtp, &nread);
 271   if (s == NULL)
 272     return 0;
 273   /* Decode the bytes read.  */
 274   for (i = 1; i < nb; i++)
 275     {
 276       gfc_char4_t n = *s++;
 277
 278       if ((n & 0xC0) != 0x80)
 279         goto invalid;
 280
 281       c = ((c << 6) + (n & 0x3F));
 282     }
 283
 284   /* Make sure the shortest possible encoding was used.  */
 285   if (c <=      0x7F && nb > 1) goto invalid;
 286   if (c <=     0x7FF && nb > 2) goto invalid;
 287   if (c <=    0xFFFF && nb > 3) goto invalid;
 288   if (c <=  0x1FFFFF && nb > 4) goto invalid;
 289   if (c <= 0x3FFFFFF && nb > 5) goto invalid;
 290
 291   /* Make sure the character is valid.  */
 292   if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
 293     goto invalid;
 294
 295   return c;
 296
 297  invalid:
 298   generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
 299   return (gfc_char4_t) '?';
 300 }
 301
 302
 303 static void
 304 read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 305 {
 306   gfc_char4_t c;
 307   char *dest;
 308   int nbytes;
 309   int i, j;
 310
 311   len = (width < len) ? len : width;
 312
 313   dest = (char *) p;
 314
 315   /* Proceed with decoding one character at a time.  */
 316   for (j = 0; j < len; j++, dest++)
 317     {
 318       c = read_utf8 (dtp, &nbytes);
 319
 320       /* Check for a short read and if so, break out.  */
 321       if (nbytes == 0)
 322         break;
 323
 324       *dest = c > 255 ? '?' : (uchar) c;
 325     }
 326
 327   /* If there was a short read, pad the remaining characters.  */
 328   for (i = j; i < len; i++)
 329     *dest++ = ' ';
 330   return;
 331 }
 332
 333 static void
 334 read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 335 {
 336   char *s;
 337   int m, n;
 338
 339   s = read_block_form (dtp, &width);
 340
 341   if (s == NULL)
 342     return;
 343   if (width > len)
 344      s += (width - len);
 345
 346   m = (width > len) ? len : width;
 347   memcpy (p, s, m);
 348
 349   n = len - width;
 350   if (n > 0)
 351     memset (p + m, ' ', n);
 352 }
 353
 354
 355 static void
 356 read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
 357 {
 358   gfc_char4_t *dest;
 359   int nbytes;
 360   int i, j;
 361
 362   len = (width < len) ? len : width;
 363
 364   dest = (gfc_char4_t *) p;
 365
 366   /* Proceed with decoding one character at a time.  */
 367   for (j = 0; j < len; j++, dest++)
 368     {
 369       *dest = read_utf8 (dtp, &nbytes);
 370
 371       /* Check for a short read and if so, break out.  */
 372       if (nbytes == 0)
 373         break;
 374     }
 375
 376   /* If there was a short read, pad the remaining characters.  */
 377   for (i = j; i < len; i++)
 378     *dest++ = (gfc_char4_t) ' ';
 379   return;
 380 }
 381
 382
 383 static void
 384 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 385 {
 386   int m, n;
 387   gfc_char4_t *dest;
 388
 389   if (is_char4_unit(dtp))
 390     {
 391       gfc_char4_t *s4;
 392
 393       s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
 394
 395       if (s4 == NULL)
 396         return;
 397       if (width > len)
 398          s4 += (width - len);
 399
 400       m = ((int) width > len) ? len : (int) width;
 401
 402       dest = (gfc_char4_t *) p;
 403
 404       for (n = 0; n < m; n++)
 405         *dest++ = *s4++;
 406
 407       for (n = 0; n < len - (int) width; n++)
 408         *dest++ = (gfc_char4_t) ' ';
 409     }
 410   else
 411     {
 412       char *s;
 413
 414       s = read_block_form (dtp, &width);
 415
 416       if (s == NULL)
 417         return;
 418       if (width > len)
 419          s += (width - len);
 420
 421       m = ((int) width > len) ? len : (int) width;
 422
 423       dest = (gfc_char4_t *) p;
 424
 425       for (n = 0; n < m; n++, dest++, s++)
 426         *dest = (unsigned char ) *s;
 427
 428       for (n = 0; n < len - (int) width; n++, dest++)
 429         *dest = (unsigned char) ' ';
 430     }
 431 }
 432
 433
 434 /* read_a()-- Read a character record into a KIND=1 character destination,
 435    processing UTF-8 encoding if necessary.  */
 436
 437 void
 438 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 439 {
 440   int wi;
 441   int w;
 442
 443   wi = f->u.w;
 444   if (wi == -1) /* '(A)' edit descriptor  */
 445     wi = length;
 446   w = wi;
 447
 448   /* Read in w characters, treating comma as not a separator.  */
 449   dtp->u.p.sf_read_comma = 0;
 450
 451   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 452     read_utf8_char1 (dtp, p, length, w);
 453   else
 454     read_default_char1 (dtp, p, length, w);
 455
 456   dtp->u.p.sf_read_comma =
 457     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 458 }
 459
 460
 461 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
 462    processing UTF-8 encoding if necessary.  */
 463
 464 void
 465 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 466 {
 467   int w;
 468
 469   w = f->u.w;
 470   if (w == -1) /* '(A)' edit descriptor  */
 471     w = length;
 472
 473   /* Read in w characters, treating comma as not a separator.  */
 474   dtp->u.p.sf_read_comma = 0;
 475
 476   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 477     read_utf8_char4 (dtp, p, length, w);
 478   else
 479     read_default_char4 (dtp, p, length, w);
 480
 481   dtp->u.p.sf_read_comma =
 482     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 483 }
 484
 485 /* eat_leading_spaces()-- Given a character pointer and a width,
 486  * ignore the leading spaces.  */
 487
 488 static char *
 489 eat_leading_spaces (int *width, char *p)
 490 {
 491   for (;;)
 492     {
 493       if (*width == 0 || *p != ' ')
 494         break;
 495
 496       (*width)--;
 497       p++;
 498     }
 499
 500   return p;
 501 }
 502
 503
 504 static char
 505 next_char (st_parameter_dt *dtp, char **p, int *w)
 506 {
 507   char c, *q;
 508
 509   if (*w == 0)
 510     return '\0';
 511
 512   q = *p;
 513   c = *q++;
 514   *p = q;
 515
 516   (*w)--;
 517
 518   if (c != ' ')
 519     return c;
 520   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
 521     return ' ';  /* return a blank to signal a null */
 522
 523   /* At this point, the rest of the field has to be trailing blanks */
 524
 525   while (*w > 0)
 526     {
 527       if (*q++ != ' ')
 528         return '?';
 529       (*w)--;
 530     }
 531
 532   *p = q;
 533   return '\0';
 534 }
 535
 536
 537 /* read_decimal()-- Read a decimal integer value.  The values here are
 538  * signed values. */
 539
 540 void
 541 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 542 {
 543   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 544   GFC_INTEGER_LARGEST v;
 545   int w, negative;
 546   char c, *p;
 547
 548   w = f->u.w;
 549
 550   p = read_block_form (dtp, &w);
 551
 552   if (p == NULL)
 553     return;
 554
 555   p = eat_leading_spaces (&w, p);
 556   if (w == 0)
 557     {
 558       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 559       return;
 560     }
 561
 562   maxv = max_value (length, 1);
 563   maxv_10 = maxv / 10;
 564
 565   negative = 0;
 566   value = 0;
 567
 568   switch (*p)
 569     {
 570     case '-':
 571       negative = 1;
 572       /* Fall through */
 573
 574     case '+':
 575       p++;
 576       if (--w == 0)
 577         goto bad;
 578       /* Fall through */
 579
 580     default:
 581       break;
 582     }
 583
 584   /* At this point we have a digit-string */
 585   value = 0;
 586
 587   for (;;)
 588     {
 589       c = next_char (dtp, &p, &w);
 590       if (c == '\0')
 591         break;
 592
 593       if (c == ' ')
 594         {
 595           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 596           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 597         }
 598
 599       if (c < '0' || c > '9')
 600         goto bad;
 601
 602       if (value > maxv_10 && compile_options.range_check == 1)
 603         goto overflow;
 604
 605       c -= '0';
 606       value = 10 * value;
 607
 608       if (value > maxv - c && compile_options.range_check == 1)
 609         goto overflow;
 610       value += c;
 611     }
 612
 613   v = value;
 614   if (negative)
 615     v = -v;
 616
 617   set_integer (dest, v, length);
 618   return;
 619
 620  bad:
 621   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 622                   "Bad value during integer read");
 623   next_record (dtp, 1);
 624   return;
 625
 626  overflow:
 627   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 628                   "Value overflowed during integer read");
 629   next_record (dtp, 1);
 630
 631 }
 632
 633
 634 /* read_radix()-- This function reads values for non-decimal radixes.
 635  * The difference here is that we treat the values here as unsigned
 636  * values for the purposes of overflow.  If minus sign is present and
 637  * the top bit is set, the value will be incorrect. */
 638
 639 void
 640 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 641             int radix)
 642 {
 643   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 644   GFC_INTEGER_LARGEST v;
 645   int w, negative;
 646   char c, *p;
 647
 648   w = f->u.w;
 649
 650   p = read_block_form (dtp, &w);
 651
 652   if (p == NULL)
 653     return;
 654
 655   p = eat_leading_spaces (&w, p);
 656   if (w == 0)
 657     {
 658       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 659       return;
 660     }
 661
 662   maxv = max_value (length, 0);
 663   maxv_r = maxv / radix;
 664
 665   negative = 0;
 666   value = 0;
 667
 668   switch (*p)
 669     {
 670     case '-':
 671       negative = 1;
 672       /* Fall through */
 673
 674     case '+':
 675       p++;
 676       if (--w == 0)
 677         goto bad;
 678       /* Fall through */
 679
 680     default:
 681       break;
 682     }
 683
 684   /* At this point we have a digit-string */
 685   value = 0;
 686
 687   for (;;)
 688     {
 689       c = next_char (dtp, &p, &w);
 690       if (c == '\0')
 691         break;
 692       if (c == ' ')
 693         {
 694           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 695           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 696         }
 697
 698       switch (radix)
 699         {
 700         case 2:
 701           if (c < '0' || c > '1')
 702             goto bad;
 703           break;
 704
 705         case 8:
 706           if (c < '0' || c > '7')
 707             goto bad;
 708           break;
 709
 710         case 16:
 711           switch (c)
 712             {
 713             case '0':
 714             case '1':
 715             case '2':
 716             case '3':
 717             case '4':
 718             case '5':
 719             case '6':
 720             case '7':
 721             case '8':
 722             case '9':
 723               break;
 724
 725             case 'a':
 726             case 'b':
 727             case 'c':
 728             case 'd':
 729             case 'e':
 730             case 'f':
 731               c = c - 'a' + '9' + 1;
 732               break;
 733
 734             case 'A':
 735             case 'B':
 736             case 'C':
 737             case 'D':
 738             case 'E':
 739             case 'F':
 740               c = c - 'A' + '9' + 1;
 741               break;
 742
 743             default:
 744               goto bad;
 745             }
 746
 747           break;
 748         }
 749
 750       if (value > maxv_r)
 751         goto overflow;
 752
 753       c -= '0';
 754       value = radix * value;
 755
 756       if (maxv - c < value)
 757         goto overflow;
 758       value += c;
 759     }
 760
 761   v = value;
 762   if (negative)
 763     v = -v;
 764
 765   set_integer (dest, v, length);
 766   return;
 767
 768  bad:
 769   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 770                   "Bad value during integer read");
 771   next_record (dtp, 1);
 772   return;
 773
 774  overflow:
 775   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 776                   "Value overflowed during integer read");
 777   next_record (dtp, 1);
 778
 779 }
 780
 781
 782 /* read_f()-- Read a floating point number with F-style editing, which
 783    is what all of the other floating point descriptors behave as.  The
 784    tricky part is that optional spaces are allowed after an E or D,
 785    and the implicit decimal point if a decimal point is not present in
 786    the input.  */
 787
 788 void
 789 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 790 {
 791   int w, seen_dp, exponent;
 792   int exponent_sign;
 793   const char *p;
 794   char *buffer;
 795   char *out;
 796   int seen_int_digit; /* Seen a digit before the decimal point?  */
 797   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 798
 799   seen_dp = 0;
 800   seen_int_digit = 0;
 801   seen_dec_digit = 0;
 802   exponent_sign = 1;
 803   exponent = 0;
 804   w = f->u.w;
 805
 806   /* Read in the next block.  */
 807   p = read_block_form (dtp, &w);
 808   if (p == NULL)
 809     return;
 810   p = eat_leading_spaces (&w, (char*) p);
 811   if (w == 0)
 812     goto zero;
 813
 814   /* In this buffer we're going to re-format the number cleanly to be parsed
 815      by convert_real in the end; this assures we're using strtod from the
 816      C library for parsing and thus probably get the best accuracy possible.
 817      This process may add a '+0.0' in front of the number as well as change the
 818      exponent because of an implicit decimal point or the like.  Thus allocating
 819      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 820      original buffer had should be enough.  */
 821   buffer = gfc_alloca (w + 11);
 822   out = buffer;
 823
 824   /* Optional sign */
 825   if (*p == '-' || *p == '+')
 826     {
 827       if (*p == '-')
 828         *(out++) = '-';
 829       ++p;
 830       --w;
 831     }
 832
 833   p = eat_leading_spaces (&w, (char*) p);
 834   if (w == 0)
 835     goto zero;
 836
 837   /* Check for Infinity or NaN.  */
 838   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 839     {
 840       int seen_paren = 0;
 841       char *save = out;
 842
 843       /* Scan through the buffer keeping track of spaces and parenthesis. We
 844          null terminate the string as soon as we see a left paren or if we are
 845          BLANK_NULL mode.  Leading spaces have already been skipped above,
 846          trailing spaces are ignored by converting to '\0'. A space
 847          between "NaN" and the optional perenthesis is not permitted.  */
 848       while (w > 0)
 849         {
 850           *out = tolower (*p);
 851           switch (*p)
 852             {
 853             case ' ':
 854               if (dtp->u.p.blank_status == BLANK_ZERO)
 855                 {
 856                   *out = '0';
 857                   break;
 858                 }
 859               *out = '\0';
 860               if (seen_paren == 1)
 861                 goto bad_float;
 862               break;
 863             case '(':
 864               seen_paren++;
 865               *out = '\0';
 866               break;
 867             case ')':
 868               if (seen_paren++ != 1)
 869                 goto bad_float;
 870               break;
 871             default:
 872               if (!isalnum (*out))
 873                 goto bad_float;
 874             }
 875           --w;
 876           ++p;
 877           ++out;
 878         }
 879
 880       *out = '\0';
 881
 882       if (seen_paren != 0 && seen_paren != 2)
 883         goto bad_float;
 884
 885       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 886         {
 887            if (seen_paren)
 888              goto bad_float;
 889         }
 890       else if (strcmp (save, "nan") != 0)
 891         goto bad_float;
 892
 893       convert_real (dtp, dest, buffer, length);
 894       return;
 895     }
 896
 897   /* Process the mantissa string.  */
 898   while (w > 0)
 899     {
 900       switch (*p)
 901         {
 902         case ',':
 903           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 904             goto bad_float;
 905           /* Fall through.  */
 906         case '.':
 907           if (seen_dp)
 908             goto bad_float;
 909           if (!seen_int_digit)
 910             *(out++) = '0';
 911           *(out++) = '.';
 912           seen_dp = 1;
 913           break;
 914
 915         case ' ':
 916           if (dtp->u.p.blank_status == BLANK_ZERO)
 917             {
 918               *(out++) = '0';
 919               goto found_digit;
 920             }
 921           else if (dtp->u.p.blank_status == BLANK_NULL)
 922             break;
 923           else
 924             /* TODO: Should we check instead that there are only trailing
 925                blanks here, as is done below for exponents?  */
 926             goto done;
 927           /* Fall through.  */
 928         case '0':
 929         case '1':
 930         case '2':
 931         case '3':
 932         case '4':
 933         case '5':
 934         case '6':
 935         case '7':
 936         case '8':
 937         case '9':
 938           *(out++) = *p;
 939 found_digit:
 940           if (!seen_dp)
 941             seen_int_digit = 1;
 942           else
 943             seen_dec_digit = 1;
 944           break;
 945
 946         case '-':
 947         case '+':
 948           goto exponent;
 949
 950         case 'e':
 951         case 'E':
 952         case 'd':
 953         case 'D':
 954           ++p;
 955           --w;
 956           goto exponent;
 957
 958         default:
 959           goto bad_float;
 960         }
 961
 962       ++p;
 963       --w;
 964     }
 965
 966   /* No exponent has been seen, so we use the current scale factor.  */
 967   exponent = - dtp->u.p.scale_factor;
 968   goto done;
 969
 970   /* At this point the start of an exponent has been found.  */
 971 exponent:
 972   p = eat_leading_spaces (&w, (char*) p);
 973   if (*p == '-' || *p == '+')
 974     {
 975       if (*p == '-')
 976         exponent_sign = -1;
 977       ++p;
 978       --w;
 979     }
 980
 981   /* At this point a digit string is required.  We calculate the value
 982      of the exponent in order to take account of the scale factor and
 983      the d parameter before explict conversion takes place.  */
 984
 985   if (w == 0)
 986     goto bad_float;
 987
 988   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
 989     {
 990       while (w > 0 && isdigit (*p))
 991         {
 992           exponent *= 10;
 993           exponent += *p - '0';
 994           ++p;
 995           --w;
 996         }
 997
 998       /* Only allow trailing blanks.  */
 999       while (w > 0)
1000         {
1001           if (*p != ' ')
1002             goto bad_float;
1003           ++p;
1004           --w;
1005         }
1006     }
1007   else  /* BZ or BN status is enabled.  */
1008     {
1009       while (w > 0)
1010         {
1011           if (*p == ' ')
1012             {
1013               if (dtp->u.p.blank_status == BLANK_ZERO)
1014                 exponent *= 10;
1015               else
1016                 assert (dtp->u.p.blank_status == BLANK_NULL);
1017             }
1018           else if (!isdigit (*p))
1019             goto bad_float;
1020           else
1021             {
1022               exponent *= 10;
1023               exponent += *p - '0';
1024             }
1025
1026           ++p;
1027           --w;
1028         }
1029     }
1030
1031   exponent *= exponent_sign;
1032
1033 done:
1034   /* Use the precision specified in the format if no decimal point has been
1035      seen.  */
1036   if (!seen_dp)
1037     exponent -= f->u.real.d;
1038
1039   /* Output a trailing '0' after decimal point if not yet found.  */
1040   if (seen_dp && !seen_dec_digit)
1041     *(out++) = '0';
1042
1043   /* Print out the exponent to finish the reformatted number.  Maximum 4
1044      digits for the exponent.  */
1045   if (exponent != 0)
1046     {
1047       int dig;
1048
1049       *(out++) = 'e';
1050       if (exponent < 0)
1051         {
1052           *(out++) = '-';
1053           exponent = - exponent;
1054         }
1055
1056       assert (exponent < 10000);
1057       for (dig = 3; dig >= 0; --dig)
1058         {
1059           out[dig] = (char) ('0' + exponent % 10);
1060           exponent /= 10;
1061         }
1062       out += 4;
1063     }
1064   *(out++) = '\0';
1065
1066   /* Do the actual conversion.  */
1067   convert_real (dtp, dest, buffer, length);
1068
1069   return;
1070
1071   /* The value read is zero.  */
1072 zero:
1073   switch (length)
1074     {
1075       case 4:
1076         *((GFC_REAL_4 *) dest) = 0.0;
1077         break;
1078
1079       case 8:
1080         *((GFC_REAL_8 *) dest) = 0.0;
1081         break;
1082
1083 #ifdef HAVE_GFC_REAL_10
1084       case 10:
1085         *((GFC_REAL_10 *) dest) = 0.0;
1086         break;
1087 #endif
1088
1089 #ifdef HAVE_GFC_REAL_16
1090       case 16:
1091         *((GFC_REAL_16 *) dest) = 0.0;
1092         break;
1093 #endif
1094
1095       default:
1096         internal_error (&dtp->common, "Unsupported real kind during IO");
1097     }
1098   return;
1099
1100 bad_float:
1101   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1102                   "Bad value during floating point read");
1103   next_record (dtp, 1);
1104   return;
1105 }
1106
1107
1108 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1109  * and never look at it. */
1110
1111 void
1112 read_x (st_parameter_dt *dtp, int n)
1113 {
1114   int length;
1115   char *p, q;
1116
1117   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1118        && dtp->u.p.current_unit->bytes_left < n)
1119     n = dtp->u.p.current_unit->bytes_left;
1120
1121   if (n == 0)
1122     return;
1123
1124   length = n;
1125
1126   if (is_internal_unit (dtp))
1127     {
1128       p = mem_alloc_r (dtp->u.p.current_unit->s, &length);
1129       if (unlikely (length < n))
1130         n = length;
1131       goto done;
1132     }
1133
1134   if (dtp->u.p.sf_seen_eor)
1135     return;
1136
1137   p = fbuf_read (dtp->u.p.current_unit, &length);
1138   if (p == NULL)
1139     {
1140       hit_eof (dtp);
1141       return;
1142     }
1143
1144   if (length == 0 && dtp->u.p.item_count == 1)
1145     {
1146       if (dtp->u.p.current_unit->pad_status == PAD_NO)
1147         {
1148           hit_eof (dtp);
1149           return;
1150         }
1151       else
1152         return;
1153     }
1154
1155   n = 0;
1156   while (n < length)
1157     {
1158       q = *p;
1159       if (q == '\n' || q == '\r')
1160         {
1161           /* Unexpected end of line. Set the position.  */
1162           fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
1163           dtp->u.p.sf_seen_eor = 1;
1164
1165           /* If we encounter a CR, it might be a CRLF.  */
1166           if (q == '\r') /* Probably a CRLF */
1167             {
1168               /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
1169                  the position is not advanced unless it really is an LF.  */
1170               int readlen = 1;
1171               p = fbuf_read (dtp->u.p.current_unit, &readlen);
1172               if (*p == '\n' && readlen == 1)
1173                 {
1174                   dtp->u.p.sf_seen_eor = 2;
1175                   fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
1176                 }
1177             }
1178           goto done;
1179         }
1180       n++;
1181       p++;
1182     }
1183
1184   fbuf_seek (dtp->u.p.current_unit, n, SEEK_CUR);
1185
1186  done:
1187   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1188     dtp->u.p.size_used += (GFC_IO_INT) n;
1189   dtp->u.p.current_unit->bytes_left -= n;
1190   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1191 }
1192