libgfortran/io/read.c

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