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