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