libgfortran/io/read.c

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