gcc-4_8-branch/libgfortran/io/read.c

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