libgfortran/io/read.c

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