libgfortran/io/read.c

   1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    F2003 I/O support contributed by Jerry DeLisle
   4
   5 This file is part of the GNU Fortran runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 3, or (at your option)
  10 any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "io.h"
  27 #include "fbuf.h"
  28 #include "format.h"
  29 #include "unix.h"
  30 #include <string.h>
  31 #include <ctype.h>
  32 #include <assert.h>
  33
  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   size_t 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, size_t *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   size_t 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 (size_t 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, size_t len, size_t width)
 387 {
 388   gfc_char4_t c;
 389   char *dest;
 390   size_t nbytes, j;
 391
 392   len = (width < len) ? len : width;
 393
 394   dest = (char *) p;
 395
 396   /* Proceed with decoding one character at a time.  */
 397   for (j = 0; j < len; j++, dest++)
 398     {
 399       c = read_utf8 (dtp, &nbytes);
 400
 401       /* Check for a short read and if so, break out.  */
 402       if (nbytes == 0)
 403         break;
 404
 405       *dest = c > 255 ? '?' : (uchar) c;
 406     }
 407
 408   /* If there was a short read, pad the remaining characters.  */
 409   for (size_t i = j; i < len; i++)
 410     *dest++ = ' ';
 411   return;
 412 }
 413
 414 static void
 415 read_default_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
 416 {
 417   char *s;
 418   size_t m;
 419
 420   s = read_block_form (dtp, &width);
 421
 422   if (s == NULL)
 423     return;
 424   if (width > len)
 425      s += (width - len);
 426
 427   m = (width > len) ? len : width;
 428   memcpy (p, s, m);
 429
 430   if (len > width)
 431     memset (p + m, ' ', len - width);
 432 }
 433
 434
 435 static void
 436 read_utf8_char4 (st_parameter_dt *dtp, void *p, size_t len, size_t width)
 437 {
 438   gfc_char4_t *dest;
 439   size_t nbytes, j;
 440
 441   len = (width < len) ? len : width;
 442
 443   dest = (gfc_char4_t *) p;
 444
 445   /* Proceed with decoding one character at a time.  */
 446   for (j = 0; j < len; j++, dest++)
 447     {
 448       *dest = read_utf8 (dtp, &nbytes);
 449
 450       /* Check for a short read and if so, break out.  */
 451       if (nbytes == 0)
 452         break;
 453     }
 454
 455   /* If there was a short read, pad the remaining characters.  */
 456   for (size_t i = j; i < len; i++)
 457     *dest++ = (gfc_char4_t) ' ';
 458   return;
 459 }
 460
 461
 462 static void
 463 read_default_char4 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
 464 {
 465   size_t m, n;
 466   gfc_char4_t *dest;
 467
 468   if (is_char4_unit(dtp))
 469     {
 470       gfc_char4_t *s4;
 471
 472       s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
 473
 474       if (s4 == NULL)
 475         return;
 476       if (width > len)
 477          s4 += (width - len);
 478
 479       m = (width > len) ? len : width;
 480
 481       dest = (gfc_char4_t *) p;
 482
 483       for (n = 0; n < m; n++)
 484         *dest++ = *s4++;
 485
 486       if (len > width)
 487         {
 488           for (n = 0; n < len - width; n++)
 489             *dest++ = (gfc_char4_t) ' ';
 490         }
 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 = (width > len) ? len : 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       if (len > width)
 511         {
 512           for (n = 0; n < len - width; n++, dest++)
 513             *dest = (unsigned char) ' ';
 514         }
 515     }
 516 }
 517
 518
 519 /* read_a()-- Read a character record into a KIND=1 character destination,
 520    processing UTF-8 encoding if necessary.  */
 521
 522 void
 523 read_a (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
 524 {
 525   size_t w;
 526
 527   if (f->u.w == -1) /* '(A)' edit descriptor  */
 528     w = length;
 529   else
 530     w = f->u.w;
 531
 532   /* Read in w characters, treating comma as not a separator.  */
 533   dtp->u.p.sf_read_comma = 0;
 534
 535   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 536     read_utf8_char1 (dtp, p, length, w);
 537   else
 538     read_default_char1 (dtp, p, length, w);
 539
 540   dtp->u.p.sf_read_comma =
 541     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 542 }
 543
 544
 545 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
 546    processing UTF-8 encoding if necessary.  */
 547
 548 void
 549 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
 550 {
 551   size_t w;
 552
 553   if (f->u.w == -1) /* '(A)' edit descriptor  */
 554     w = length;
 555   else
 556     w = f->u.w;
 557
 558   /* Read in w characters, treating comma as not a separator.  */
 559   dtp->u.p.sf_read_comma = 0;
 560
 561   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 562     read_utf8_char4 (dtp, p, length, w);
 563   else
 564     read_default_char4 (dtp, p, length, w);
 565
 566   dtp->u.p.sf_read_comma =
 567     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 568 }
 569
 570 /* eat_leading_spaces()-- Given a character pointer and a width,
 571    ignore the leading spaces.  */
 572
 573 static char *
 574 eat_leading_spaces (size_t *width, char *p)
 575 {
 576   for (;;)
 577     {
 578       if (*width == 0 || *p != ' ')
 579         break;
 580
 581       (*width)--;
 582       p++;
 583     }
 584
 585   return p;
 586 }
 587
 588
 589 static char
 590 next_char (st_parameter_dt *dtp, char **p, size_t *w)
 591 {
 592   char c, *q;
 593
 594   if (*w == 0)
 595     return '\0';
 596
 597   q = *p;
 598   c = *q++;
 599   *p = q;
 600
 601   (*w)--;
 602
 603   if (c != ' ')
 604     return c;
 605   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
 606     return ' ';  /* return a blank to signal a null */
 607
 608   /* At this point, the rest of the field has to be trailing blanks */
 609
 610   while (*w > 0)
 611     {
 612       if (*q++ != ' ')
 613         return '?';
 614       (*w)--;
 615     }
 616
 617   *p = q;
 618   return '\0';
 619 }
 620
 621
 622 /* read_decimal()-- Read a decimal integer value.  The values here are
 623    signed values. */
 624
 625 void
 626 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 627 {
 628   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 629   GFC_INTEGER_LARGEST v;
 630   size_t w;
 631   int negative;
 632   char c, *p;
 633
 634   w = f->u.w;
 635
 636   p = read_block_form (dtp, &w);
 637
 638   if (p == NULL)
 639     return;
 640
 641   p = eat_leading_spaces (&w, p);
 642   if (w == 0)
 643     {
 644       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 645       return;
 646     }
 647
 648   negative = 0;
 649
 650   switch (*p)
 651     {
 652     case '-':
 653       negative = 1;
 654       /* Fall through */
 655
 656     case '+':
 657       p++;
 658       if (--w == 0)
 659         goto bad;
 660       /* Fall through */
 661
 662     default:
 663       break;
 664     }
 665
 666   maxv = si_max (length);
 667   if (negative)
 668     maxv++;
 669   maxv_10 = maxv / 10;
 670
 671   /* At this point we have a digit-string */
 672   value = 0;
 673
 674   for (;;)
 675     {
 676       c = next_char (dtp, &p, &w);
 677       if (c == '\0')
 678         break;
 679
 680       if (c == ' ')
 681         {
 682           if (dtp->u.p.blank_status == BLANK_NULL)
 683             {
 684               /* Skip spaces.  */
 685               for ( ; w > 0; p++, w--)
 686                 if (*p != ' ') break;
 687               continue;
 688             }
 689           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 690         }
 691
 692       if (c < '0' || c > '9')
 693         goto bad;
 694
 695       if (value > maxv_10)
 696         goto overflow;
 697
 698       c -= '0';
 699       value = 10 * value;
 700
 701       if (value > maxv - c)
 702         goto overflow;
 703       value += c;
 704     }
 705
 706   if (negative)
 707     v = -value;
 708   else
 709     v = value;
 710
 711   set_integer (dest, v, length);
 712   return;
 713
 714  bad:
 715   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 716                   "Bad value during integer read");
 717   next_record (dtp, 1);
 718   return;
 719
 720  overflow:
 721   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 722                   "Value overflowed during integer read");
 723   next_record (dtp, 1);
 724
 725 }
 726
 727
 728 /* read_radix()-- This function reads values for non-decimal radixes.
 729    The difference here is that we treat the values here as unsigned
 730    values for the purposes of overflow.  If minus sign is present and
 731    the top bit is set, the value will be incorrect. */
 732
 733 void
 734 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 735             int radix)
 736 {
 737   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 738   GFC_INTEGER_LARGEST v;
 739   size_t w;
 740   int negative;
 741   char c, *p;
 742
 743   w = f->u.w;
 744
 745   p = read_block_form (dtp, &w);
 746
 747   if (p == NULL)
 748     return;
 749
 750   p = eat_leading_spaces (&w, p);
 751   if (w == 0)
 752     {
 753       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 754       return;
 755     }
 756
 757   /* Maximum unsigned value, assuming two's complement.  */
 758   maxv = 2 * si_max (length) + 1;
 759   maxv_r = maxv / radix;
 760
 761   negative = 0;
 762   value = 0;
 763
 764   switch (*p)
 765     {
 766     case '-':
 767       negative = 1;
 768       /* Fall through */
 769
 770     case '+':
 771       p++;
 772       if (--w == 0)
 773         goto bad;
 774       /* Fall through */
 775
 776     default:
 777       break;
 778     }
 779
 780   /* At this point we have a digit-string */
 781   value = 0;
 782
 783   for (;;)
 784     {
 785       c = next_char (dtp, &p, &w);
 786       if (c == '\0')
 787         break;
 788       if (c == ' ')
 789         {
 790           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 791           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 792         }
 793
 794       switch (radix)
 795         {
 796         case 2:
 797           if (c < '0' || c > '1')
 798             goto bad;
 799           break;
 800
 801         case 8:
 802           if (c < '0' || c > '7')
 803             goto bad;
 804           break;
 805
 806         case 16:
 807           switch (c)
 808             {
 809             case '0':
 810             case '1':
 811             case '2':
 812             case '3':
 813             case '4':
 814             case '5':
 815             case '6':
 816             case '7':
 817             case '8':
 818             case '9':
 819               break;
 820
 821             case 'a':
 822             case 'b':
 823             case 'c':
 824             case 'd':
 825             case 'e':
 826             case 'f':
 827               c = c - 'a' + '9' + 1;
 828               break;
 829
 830             case 'A':
 831             case 'B':
 832             case 'C':
 833             case 'D':
 834             case 'E':
 835             case 'F':
 836               c = c - 'A' + '9' + 1;
 837               break;
 838
 839             default:
 840               goto bad;
 841             }
 842
 843           break;
 844         }
 845
 846       if (value > maxv_r)
 847         goto overflow;
 848
 849       c -= '0';
 850       value = radix * value;
 851
 852       if (maxv - c < value)
 853         goto overflow;
 854       value += c;
 855     }
 856
 857   v = value;
 858   if (negative)
 859     v = -v;
 860
 861   set_integer (dest, v, length);
 862   return;
 863
 864  bad:
 865   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 866                   "Bad value during integer read");
 867   next_record (dtp, 1);
 868   return;
 869
 870  overflow:
 871   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 872                   "Value overflowed during integer read");
 873   next_record (dtp, 1);
 874
 875 }
 876
 877
 878 /* read_f()-- Read a floating point number with F-style editing, which
 879    is what all of the other floating point descriptors behave as.  The
 880    tricky part is that optional spaces are allowed after an E or D,
 881    and the implicit decimal point if a decimal point is not present in
 882    the input.  */
 883
 884 void
 885 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 886 {
 887 #define READF_TMP 50
 888   char tmp[READF_TMP];
 889   size_t buf_size = 0;
 890   size_t w;
 891   int seen_dp, exponent;
 892   int exponent_sign;
 893   const char *p;
 894   char *buffer;
 895   char *out;
 896   int seen_int_digit; /* Seen a digit before the decimal point?  */
 897   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 898
 899   seen_dp = 0;
 900   seen_int_digit = 0;
 901   seen_dec_digit = 0;
 902   exponent_sign = 1;
 903   exponent = 0;
 904   w = f->u.w;
 905   buffer = tmp;
 906
 907   /* Read in the next block.  */
 908   p = read_block_form (dtp, &w);
 909   if (p == NULL)
 910     return;
 911   p = eat_leading_spaces (&w, (char*) p);
 912   if (w == 0)
 913     goto zero;
 914
 915   /* In this buffer we're going to re-format the number cleanly to be parsed
 916      by convert_real in the end; this assures we're using strtod from the
 917      C library for parsing and thus probably get the best accuracy possible.
 918      This process may add a '+0.0' in front of the number as well as change the
 919      exponent because of an implicit decimal point or the like.  Thus allocating
 920      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 921      original buffer had should be enough.  */
 922   buf_size = w + 11;
 923   if (buf_size > READF_TMP)
 924     buffer = xmalloc (buf_size);
 925
 926   out = buffer;
 927
 928   /* Optional sign */
 929   if (*p == '-' || *p == '+')
 930     {
 931       if (*p == '-')
 932         *(out++) = '-';
 933       ++p;
 934       --w;
 935     }
 936
 937   p = eat_leading_spaces (&w, (char*) p);
 938   if (w == 0)
 939     goto zero;
 940
 941   /* Check for Infinity or NaN.  */
 942   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 943     {
 944       int seen_paren = 0;
 945       char *save = out;
 946
 947       /* Scan through the buffer keeping track of spaces and parenthesis. We
 948          null terminate the string as soon as we see a left paren or if we are
 949          BLANK_NULL mode.  Leading spaces have already been skipped above,
 950          trailing spaces are ignored by converting to '\0'. A space
 951          between "NaN" and the optional perenthesis is not permitted.  */
 952       while (w > 0)
 953         {
 954           *out = tolower (*p);
 955           switch (*p)
 956             {
 957             case ' ':
 958               if (dtp->u.p.blank_status == BLANK_ZERO)
 959                 {
 960                   *out = '0';
 961                   break;
 962                 }
 963               *out = '\0';
 964               if (seen_paren == 1)
 965                 goto bad_float;
 966               break;
 967             case '(':
 968               seen_paren++;
 969               *out = '\0';
 970               break;
 971             case ')':
 972               if (seen_paren++ != 1)
 973                 goto bad_float;
 974               break;
 975             default:
 976               if (!isalnum (*out))
 977                 goto bad_float;
 978             }
 979           --w;
 980           ++p;
 981           ++out;
 982         }
 983
 984       *out = '\0';
 985
 986       if (seen_paren != 0 && seen_paren != 2)
 987         goto bad_float;
 988
 989       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 990         {
 991            if (seen_paren)
 992              goto bad_float;
 993         }
 994       else if (strcmp (save, "nan") != 0)
 995         goto bad_float;
 996
 997       convert_infnan (dtp, dest, buffer, length);
 998       if (buf_size > READF_TMP)
 999         free (buffer);
1000       return;
1001     }
1002
1003   /* Process the mantissa string.  */
1004   while (w > 0)
1005     {
1006       switch (*p)
1007         {
1008         case ',':
1009           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
1010             goto bad_float;
1011           /* Fall through.  */
1012         case '.':
1013           if (seen_dp)
1014             goto bad_float;
1015           if (!seen_int_digit)
1016             *(out++) = '0';
1017           *(out++) = '.';
1018           seen_dp = 1;
1019           break;
1020
1021         case ' ':
1022           if (dtp->u.p.blank_status == BLANK_ZERO)
1023             {
1024               *(out++) = '0';
1025               goto found_digit;
1026             }
1027           else if (dtp->u.p.blank_status == BLANK_NULL)
1028             break;
1029           else
1030             /* TODO: Should we check instead that there are only trailing
1031                blanks here, as is done below for exponents?  */
1032             goto done;
1033           /* Fall through.  */
1034         case '0':
1035         case '1':
1036         case '2':
1037         case '3':
1038         case '4':
1039         case '5':
1040         case '6':
1041         case '7':
1042         case '8':
1043         case '9':
1044           *(out++) = *p;
1045 found_digit:
1046           if (!seen_dp)
1047             seen_int_digit = 1;
1048           else
1049             seen_dec_digit = 1;
1050           break;
1051
1052         case '-':
1053         case '+':
1054           goto exponent;
1055
1056         case 'e':
1057         case 'E':
1058         case 'd':
1059         case 'D':
1060         case 'q':
1061         case 'Q':
1062           ++p;
1063           --w;
1064           goto exponent;
1065
1066         default:
1067           goto bad_float;
1068         }
1069
1070       ++p;
1071       --w;
1072     }
1073
1074   /* No exponent has been seen, so we use the current scale factor.  */
1075   exponent = - dtp->u.p.scale_factor;
1076   goto done;
1077
1078   /* At this point the start of an exponent has been found.  */
1079 exponent:
1080   p = eat_leading_spaces (&w, (char*) p);
1081   if (*p == '-' || *p == '+')
1082     {
1083       if (*p == '-')
1084         exponent_sign = -1;
1085       ++p;
1086       --w;
1087     }
1088
1089   /* At this point a digit string is required.  We calculate the value
1090      of the exponent in order to take account of the scale factor and
1091      the d parameter before explict conversion takes place.  */
1092
1093   if (w == 0)
1094     {
1095       /* Extension: allow default exponent of 0 when omitted.  */
1096       if (dtp->common.flags & IOPARM_DT_DEFAULT_EXP)
1097         goto done;
1098       else
1099         goto bad_float;
1100     }
1101
1102   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1103     {
1104       while (w > 0 && isdigit (*p))
1105         {
1106           exponent *= 10;
1107           exponent += *p - '0';
1108           ++p;
1109           --w;
1110         }
1111
1112       /* Only allow trailing blanks.  */
1113       while (w > 0)
1114         {
1115           if (*p != ' ')
1116             goto bad_float;
1117           ++p;
1118           --w;
1119         }
1120     }
1121   else  /* BZ or BN status is enabled.  */
1122     {
1123       while (w > 0)
1124         {
1125           if (*p == ' ')
1126             {
1127               if (dtp->u.p.blank_status == BLANK_ZERO)
1128                 exponent *= 10;
1129               else
1130                 assert (dtp->u.p.blank_status == BLANK_NULL);
1131             }
1132           else if (!isdigit (*p))
1133             goto bad_float;
1134           else
1135             {
1136               exponent *= 10;
1137               exponent += *p - '0';
1138             }
1139
1140           ++p;
1141           --w;
1142         }
1143     }
1144
1145   exponent *= exponent_sign;
1146
1147 done:
1148   /* Use the precision specified in the format if no decimal point has been
1149      seen.  */
1150   if (!seen_dp)
1151     exponent -= f->u.real.d;
1152
1153   /* Output a trailing '0' after decimal point if not yet found.  */
1154   if (seen_dp && !seen_dec_digit)
1155     *(out++) = '0';
1156   /* Handle input of style "E+NN" by inserting a 0 for the
1157      significand.  */
1158   else if (!seen_int_digit && !seen_dec_digit)
1159     {
1160       notify_std (&dtp->common, GFC_STD_LEGACY,
1161                   "REAL input of style 'E+NN'");
1162       *(out++) = '0';
1163     }
1164
1165   /* Print out the exponent to finish the reformatted number.  Maximum 4
1166      digits for the exponent.  */
1167   if (exponent != 0)
1168     {
1169       int dig;
1170
1171       *(out++) = 'e';
1172       if (exponent < 0)
1173         {
1174           *(out++) = '-';
1175           exponent = - exponent;
1176         }
1177
1178       if (exponent >= 10000)
1179         goto bad_float;
1180
1181       for (dig = 3; dig >= 0; --dig)
1182         {
1183           out[dig] = (char) ('0' + exponent % 10);
1184           exponent /= 10;
1185         }
1186       out += 4;
1187     }
1188   *(out++) = '\0';
1189
1190   /* Do the actual conversion.  */
1191   convert_real (dtp, dest, buffer, length);
1192   if (buf_size > READF_TMP)
1193     free (buffer);
1194   return;
1195
1196   /* The value read is zero.  */
1197 zero:
1198   switch (length)
1199     {
1200       case 4:
1201         *((GFC_REAL_4 *) dest) = 0.0;
1202         break;
1203
1204       case 8:
1205         *((GFC_REAL_8 *) dest) = 0.0;
1206         break;
1207
1208 #ifdef HAVE_GFC_REAL_10
1209       case 10:
1210         *((GFC_REAL_10 *) dest) = 0.0;
1211         break;
1212 #endif
1213
1214 #ifdef HAVE_GFC_REAL_16
1215       case 16:
1216         *((GFC_REAL_16 *) dest) = 0.0;
1217         break;
1218 #endif
1219
1220       default:
1221         internal_error (&dtp->common, "Unsupported real kind during IO");
1222     }
1223   return;
1224
1225 bad_float:
1226   if (buf_size > READF_TMP)
1227     free (buffer);
1228   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1229                   "Bad value during floating point read");
1230   next_record (dtp, 1);
1231   return;
1232 }
1233
1234
1235 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1236    and never look at it. */
1237
1238 void
1239 read_x (st_parameter_dt *dtp, size_t n)
1240 {
1241   size_t length;
1242   int q, q2;
1243
1244   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1245       && dtp->u.p.current_unit->bytes_left < (gfc_offset) n)
1246     n = dtp->u.p.current_unit->bytes_left;
1247
1248   if (n == 0)
1249     return;
1250
1251   length = n;
1252
1253   if (is_internal_unit (dtp))
1254     {
1255       mem_alloc_r (dtp->u.p.current_unit->s, &length);
1256       if (unlikely (length < n))
1257         n = length;
1258       goto done;
1259     }
1260
1261   if (dtp->u.p.sf_seen_eor)
1262     return;
1263
1264   n = 0;
1265   while (n < length)
1266     {
1267       q = fbuf_getc (dtp->u.p.current_unit);
1268       if (q == EOF)
1269         break;
1270       else if (dtp->u.p.current_unit->flags.cc != CC_NONE
1271                && (q == '\n' || q == '\r'))
1272         {
1273           /* Unexpected end of line. Set the position.  */
1274           dtp->u.p.sf_seen_eor = 1;
1275
1276           /* If we see an EOR during non-advancing I/O, we need to skip
1277              the rest of the I/O statement.  Set the corresponding flag.  */
1278           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1279             dtp->u.p.eor_condition = 1;
1280
1281           /* If we encounter a CR, it might be a CRLF.  */
1282           if (q == '\r') /* Probably a CRLF */
1283             {
1284               /* See if there is an LF.  */
1285               q2 = fbuf_getc (dtp->u.p.current_unit);
1286               if (q2 == '\n')
1287                 dtp->u.p.sf_seen_eor = 2;
1288               else if (q2 != EOF) /* Oops, seek back.  */
1289                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1290             }
1291           goto done;
1292         }
1293       n++;
1294     }
1295
1296  done:
1297   if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
1298       dtp->u.p.current_unit->has_size)
1299     dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
1300   dtp->u.p.current_unit->bytes_left -= n;
1301   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1302 }
1303