libgfortran/io/read.c

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