libgfortran/io/read.c

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