libgfortran/io/read.c

   1 /* Copyright (C) 2002-2020 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   /* This is a legacy extension, and the frontend will only allow such cases
 639    * through when -fdec-format-defaults is passed.
 640    */
 641   if (w == (size_t) DEFAULT_WIDTH)
 642     w = default_width_for_integer (length);
 643
 644   p = read_block_form (dtp, &w);
 645
 646   if (p == NULL)
 647     return;
 648
 649   p = eat_leading_spaces (&w, p);
 650   if (w == 0)
 651     {
 652       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 653       return;
 654     }
 655
 656   negative = 0;
 657
 658   switch (*p)
 659     {
 660     case '-':
 661       negative = 1;
 662       /* Fall through */
 663
 664     case '+':
 665       p++;
 666       if (--w == 0)
 667         goto bad;
 668       /* Fall through */
 669
 670     default:
 671       break;
 672     }
 673
 674   maxv = si_max (length);
 675   if (negative)
 676     maxv++;
 677   maxv_10 = maxv / 10;
 678
 679   /* At this point we have a digit-string */
 680   value = 0;
 681
 682   for (;;)
 683     {
 684       c = next_char (dtp, &p, &w);
 685       if (c == '\0')
 686         break;
 687
 688       if (c == ' ')
 689         {
 690           if (dtp->u.p.blank_status == BLANK_NULL)
 691             {
 692               /* Skip spaces.  */
 693               for ( ; w > 0; p++, w--)
 694                 if (*p != ' ') break;
 695               continue;
 696             }
 697           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 698         }
 699
 700       if (c < '0' || c > '9')
 701         goto bad;
 702
 703       if (value > maxv_10)
 704         goto overflow;
 705
 706       c -= '0';
 707       value = 10 * value;
 708
 709       if (value > maxv - c)
 710         goto overflow;
 711       value += c;
 712     }
 713
 714   if (negative)
 715     v = -value;
 716   else
 717     v = value;
 718
 719   set_integer (dest, v, length);
 720   return;
 721
 722  bad:
 723   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 724                   "Bad value during integer read");
 725   next_record (dtp, 1);
 726   return;
 727
 728  overflow:
 729   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 730                   "Value overflowed during integer read");
 731   next_record (dtp, 1);
 732
 733 }
 734
 735
 736 /* read_radix()-- This function reads values for non-decimal radixes.
 737    The difference here is that we treat the values here as unsigned
 738    values for the purposes of overflow.  If minus sign is present and
 739    the top bit is set, the value will be incorrect. */
 740
 741 void
 742 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 743             int radix)
 744 {
 745   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 746   GFC_INTEGER_LARGEST v;
 747   size_t w;
 748   int negative;
 749   char c, *p;
 750
 751   w = f->u.w;
 752
 753   p = read_block_form (dtp, &w);
 754
 755   if (p == NULL)
 756     return;
 757
 758   p = eat_leading_spaces (&w, p);
 759   if (w == 0)
 760     {
 761       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 762       return;
 763     }
 764
 765   /* Maximum unsigned value, assuming two's complement.  */
 766   maxv = 2 * si_max (length) + 1;
 767   maxv_r = maxv / radix;
 768
 769   negative = 0;
 770   value = 0;
 771
 772   switch (*p)
 773     {
 774     case '-':
 775       negative = 1;
 776       /* Fall through */
 777
 778     case '+':
 779       p++;
 780       if (--w == 0)
 781         goto bad;
 782       /* Fall through */
 783
 784     default:
 785       break;
 786     }
 787
 788   /* At this point we have a digit-string */
 789   value = 0;
 790
 791   for (;;)
 792     {
 793       c = next_char (dtp, &p, &w);
 794       if (c == '\0')
 795         break;
 796       if (c == ' ')
 797         {
 798           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 799           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 800         }
 801
 802       switch (radix)
 803         {
 804         case 2:
 805           if (c < '0' || c > '1')
 806             goto bad;
 807           break;
 808
 809         case 8:
 810           if (c < '0' || c > '7')
 811             goto bad;
 812           break;
 813
 814         case 16:
 815           switch (c)
 816             {
 817             case '0':
 818             case '1':
 819             case '2':
 820             case '3':
 821             case '4':
 822             case '5':
 823             case '6':
 824             case '7':
 825             case '8':
 826             case '9':
 827               break;
 828
 829             case 'a':
 830             case 'b':
 831             case 'c':
 832             case 'd':
 833             case 'e':
 834             case 'f':
 835               c = c - 'a' + '9' + 1;
 836               break;
 837
 838             case 'A':
 839             case 'B':
 840             case 'C':
 841             case 'D':
 842             case 'E':
 843             case 'F':
 844               c = c - 'A' + '9' + 1;
 845               break;
 846
 847             default:
 848               goto bad;
 849             }
 850
 851           break;
 852         }
 853
 854       if (value > maxv_r)
 855         goto overflow;
 856
 857       c -= '0';
 858       value = radix * value;
 859
 860       if (maxv - c < value)
 861         goto overflow;
 862       value += c;
 863     }
 864
 865   v = value;
 866   if (negative)
 867     v = -v;
 868
 869   set_integer (dest, v, length);
 870   return;
 871
 872  bad:
 873   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 874                   "Bad value during integer read");
 875   next_record (dtp, 1);
 876   return;
 877
 878  overflow:
 879   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 880                   "Value overflowed during integer read");
 881   next_record (dtp, 1);
 882
 883 }
 884
 885
 886 /* read_f()-- Read a floating point number with F-style editing, which
 887    is what all of the other floating point descriptors behave as.  The
 888    tricky part is that optional spaces are allowed after an E or D,
 889    and the implicit decimal point if a decimal point is not present in
 890    the input.  */
 891
 892 void
 893 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 894 {
 895 #define READF_TMP 50
 896   char tmp[READF_TMP];
 897   size_t buf_size = 0;
 898   size_t w;
 899   int seen_dp, exponent;
 900   int exponent_sign;
 901   const char *p;
 902   char *buffer;
 903   char *out;
 904   int seen_int_digit; /* Seen a digit before the decimal point?  */
 905   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 906
 907   seen_dp = 0;
 908   seen_int_digit = 0;
 909   seen_dec_digit = 0;
 910   exponent_sign = 1;
 911   exponent = 0;
 912   w = f->u.w;
 913   buffer = tmp;
 914
 915   /* Read in the next block.  */
 916   p = read_block_form (dtp, &w);
 917   if (p == NULL)
 918     return;
 919   p = eat_leading_spaces (&w, (char*) p);
 920   if (w == 0)
 921     goto zero;
 922
 923   /* In this buffer we're going to re-format the number cleanly to be parsed
 924      by convert_real in the end; this assures we're using strtod from the
 925      C library for parsing and thus probably get the best accuracy possible.
 926      This process may add a '+0.0' in front of the number as well as change the
 927      exponent because of an implicit decimal point or the like.  Thus allocating
 928      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 929      original buffer had should be enough.  */
 930   buf_size = w + 11;
 931   if (buf_size > READF_TMP)
 932     buffer = xmalloc (buf_size);
 933
 934   out = buffer;
 935
 936   /* Optional sign */
 937   if (*p == '-' || *p == '+')
 938     {
 939       if (*p == '-')
 940         *(out++) = '-';
 941       ++p;
 942       --w;
 943     }
 944
 945   p = eat_leading_spaces (&w, (char*) p);
 946   if (w == 0)
 947     goto zero;
 948
 949   /* Check for Infinity or NaN.  */
 950   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 951     {
 952       int seen_paren = 0;
 953       char *save = out;
 954
 955       /* Scan through the buffer keeping track of spaces and parenthesis. We
 956          null terminate the string as soon as we see a left paren or if we are
 957          BLANK_NULL mode.  Leading spaces have already been skipped above,
 958          trailing spaces are ignored by converting to '\0'. A space
 959          between "NaN" and the optional perenthesis is not permitted.  */
 960       while (w > 0)
 961         {
 962           *out = tolower (*p);
 963           switch (*p)
 964             {
 965             case ' ':
 966               if (dtp->u.p.blank_status == BLANK_ZERO)
 967                 {
 968                   *out = '0';
 969                   break;
 970                 }
 971               *out = '\0';
 972               if (seen_paren == 1)
 973                 goto bad_float;
 974               break;
 975             case '(':
 976               seen_paren++;
 977               *out = '\0';
 978               break;
 979             case ')':
 980               if (seen_paren++ != 1)
 981                 goto bad_float;
 982               break;
 983             default:
 984               if (!isalnum (*out))
 985                 goto bad_float;
 986             }
 987           --w;
 988           ++p;
 989           ++out;
 990         }
 991
 992       *out = '\0';
 993
 994       if (seen_paren != 0 && seen_paren != 2)
 995         goto bad_float;
 996
 997       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 998         {
 999            if (seen_paren)
1000              goto bad_float;
1001         }
1002       else if (strcmp (save, "nan") != 0)
1003         goto bad_float;
1004
1005       convert_infnan (dtp, dest, buffer, length);
1006       if (buf_size > READF_TMP)
1007         free (buffer);
1008       return;
1009     }
1010
1011   /* Process the mantissa string.  */
1012   while (w > 0)
1013     {
1014       switch (*p)
1015         {
1016         case ',':
1017           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
1018             goto bad_float;
1019           /* Fall through.  */
1020         case '.':
1021           if (seen_dp)
1022             goto bad_float;
1023           if (!seen_int_digit)
1024             *(out++) = '0';
1025           *(out++) = '.';
1026           seen_dp = 1;
1027           break;
1028
1029         case ' ':
1030           if (dtp->u.p.blank_status == BLANK_ZERO)
1031             {
1032               *(out++) = '0';
1033               goto found_digit;
1034             }
1035           else if (dtp->u.p.blank_status == BLANK_NULL)
1036             break;
1037           else
1038             /* TODO: Should we check instead that there are only trailing
1039                blanks here, as is done below for exponents?  */
1040             goto done;
1041           /* Fall through.  */
1042         case '0':
1043         case '1':
1044         case '2':
1045         case '3':
1046         case '4':
1047         case '5':
1048         case '6':
1049         case '7':
1050         case '8':
1051         case '9':
1052           *(out++) = *p;
1053 found_digit:
1054           if (!seen_dp)
1055             seen_int_digit = 1;
1056           else
1057             seen_dec_digit = 1;
1058           break;
1059
1060         case '-':
1061         case '+':
1062           goto exponent;
1063
1064         case 'e':
1065         case 'E':
1066         case 'd':
1067         case 'D':
1068         case 'q':
1069         case 'Q':
1070           ++p;
1071           --w;
1072           goto exponent;
1073
1074         default:
1075           goto bad_float;
1076         }
1077
1078       ++p;
1079       --w;
1080     }
1081
1082   /* No exponent has been seen, so we use the current scale factor.  */
1083   exponent = - dtp->u.p.scale_factor;
1084   goto done;
1085
1086   /* At this point the start of an exponent has been found.  */
1087 exponent:
1088   p = eat_leading_spaces (&w, (char*) p);
1089   if (*p == '-' || *p == '+')
1090     {
1091       if (*p == '-')
1092         exponent_sign = -1;
1093       ++p;
1094       --w;
1095     }
1096
1097   /* At this point a digit string is required.  We calculate the value
1098      of the exponent in order to take account of the scale factor and
1099      the d parameter before explict conversion takes place.  */
1100
1101   if (w == 0)
1102     {
1103       /* Extension: allow default exponent of 0 when omitted.  */
1104       if (dtp->common.flags & IOPARM_DT_DEC_EXT)
1105         goto done;
1106       else
1107         goto bad_float;
1108     }
1109
1110   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1111     {
1112       while (w > 0 && isdigit (*p))
1113         {
1114           exponent *= 10;
1115           exponent += *p - '0';
1116           ++p;
1117           --w;
1118         }
1119
1120       /* Only allow trailing blanks.  */
1121       while (w > 0)
1122         {
1123           if (*p != ' ')
1124             goto bad_float;
1125           ++p;
1126           --w;
1127         }
1128     }
1129   else  /* BZ or BN status is enabled.  */
1130     {
1131       while (w > 0)
1132         {
1133           if (*p == ' ')
1134             {
1135               if (dtp->u.p.blank_status == BLANK_ZERO)
1136                 exponent *= 10;
1137               else
1138                 assert (dtp->u.p.blank_status == BLANK_NULL);
1139             }
1140           else if (!isdigit (*p))
1141             goto bad_float;
1142           else
1143             {
1144               exponent *= 10;
1145               exponent += *p - '0';
1146             }
1147
1148           ++p;
1149           --w;
1150         }
1151     }
1152
1153   exponent *= exponent_sign;
1154
1155 done:
1156   /* Use the precision specified in the format if no decimal point has been
1157      seen.  */
1158   if (!seen_dp)
1159     exponent -= f->u.real.d;
1160
1161   /* Output a trailing '0' after decimal point if not yet found.  */
1162   if (seen_dp && !seen_dec_digit)
1163     *(out++) = '0';
1164   /* Handle input of style "E+NN" by inserting a 0 for the
1165      significand.  */
1166   else if (!seen_int_digit && !seen_dec_digit)
1167     {
1168       notify_std (&dtp->common, GFC_STD_LEGACY,
1169                   "REAL input of style 'E+NN'");
1170       *(out++) = '0';
1171     }
1172
1173   /* Print out the exponent to finish the reformatted number.  Maximum 4
1174      digits for the exponent.  */
1175   if (exponent != 0)
1176     {
1177       int dig;
1178
1179       *(out++) = 'e';
1180       if (exponent < 0)
1181         {
1182           *(out++) = '-';
1183           exponent = - exponent;
1184         }
1185
1186       if (exponent >= 10000)
1187         goto bad_float;
1188
1189       for (dig = 3; dig >= 0; --dig)
1190         {
1191           out[dig] = (char) ('0' + exponent % 10);
1192           exponent /= 10;
1193         }
1194       out += 4;
1195     }
1196   *(out++) = '\0';
1197
1198   /* Do the actual conversion.  */
1199   convert_real (dtp, dest, buffer, length);
1200   if (buf_size > READF_TMP)
1201     free (buffer);
1202   return;
1203
1204   /* The value read is zero.  */
1205 zero:
1206   switch (length)
1207     {
1208       case 4:
1209         *((GFC_REAL_4 *) dest) = 0.0;
1210         break;
1211
1212       case 8:
1213         *((GFC_REAL_8 *) dest) = 0.0;
1214         break;
1215
1216 #ifdef HAVE_GFC_REAL_10
1217       case 10:
1218         *((GFC_REAL_10 *) dest) = 0.0;
1219         break;
1220 #endif
1221
1222 #ifdef HAVE_GFC_REAL_16
1223       case 16:
1224         *((GFC_REAL_16 *) dest) = 0.0;
1225         break;
1226 #endif
1227
1228       default:
1229         internal_error (&dtp->common, "Unsupported real kind during IO");
1230     }
1231   return;
1232
1233 bad_float:
1234   if (buf_size > READF_TMP)
1235     free (buffer);
1236   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1237                   "Bad value during floating point read");
1238   next_record (dtp, 1);
1239   return;
1240 }
1241
1242
1243 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1244    and never look at it. */
1245
1246 void
1247 read_x (st_parameter_dt *dtp, size_t n)
1248 {
1249   size_t length;
1250   int q, q2;
1251
1252   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1253       && dtp->u.p.current_unit->bytes_left < (gfc_offset) n)
1254     n = dtp->u.p.current_unit->bytes_left;
1255
1256   if (n == 0)
1257     return;
1258
1259   length = n;
1260
1261   if (is_internal_unit (dtp))
1262     {
1263       mem_alloc_r (dtp->u.p.current_unit->s, &length);
1264       if (unlikely (length < n))
1265         n = length;
1266       goto done;
1267     }
1268
1269   if (dtp->u.p.sf_seen_eor)
1270     return;
1271
1272   n = 0;
1273   while (n < length)
1274     {
1275       q = fbuf_getc (dtp->u.p.current_unit);
1276       if (q == EOF)
1277         break;
1278       else if (dtp->u.p.current_unit->flags.cc != CC_NONE
1279                && (q == '\n' || q == '\r'))
1280         {
1281           /* Unexpected end of line. Set the position.  */
1282           dtp->u.p.sf_seen_eor = 1;
1283
1284           /* If we see an EOR during non-advancing I/O, we need to skip
1285              the rest of the I/O statement.  Set the corresponding flag.  */
1286           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1287             dtp->u.p.eor_condition = 1;
1288
1289           /* If we encounter a CR, it might be a CRLF.  */
1290           if (q == '\r') /* Probably a CRLF */
1291             {
1292               /* See if there is an LF.  */
1293               q2 = fbuf_getc (dtp->u.p.current_unit);
1294               if (q2 == '\n')
1295                 dtp->u.p.sf_seen_eor = 2;
1296               else if (q2 != EOF) /* Oops, seek back.  */
1297                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1298             }
1299           goto done;
1300         }
1301       n++;
1302     }
1303
1304  done:
1305   if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
1306       dtp->u.p.current_unit->has_size)
1307     dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
1308   dtp->u.p.current_unit->bytes_left -= n;
1309   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1310 }
1311