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)
 671             {
 672               /* Skip spaces.  */
 673               for ( ; w > 0; p++, w--)
 674                 if (*p != ' ') break;
 675               continue;
 676             }
 677           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 678         }
 679
 680       if (c < '0' || c > '9')
 681         goto bad;
 682
 683       if (value > maxv_10 && compile_options.range_check == 1)
 684         goto overflow;
 685
 686       c -= '0';
 687       value = 10 * value;
 688
 689       if (value > maxv - c && compile_options.range_check == 1)
 690         goto overflow;
 691       value += c;
 692     }
 693
 694   v = value;
 695   if (negative)
 696     v = -v;
 697
 698   set_integer (dest, v, length);
 699   return;
 700
 701  bad:
 702   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 703                   "Bad value during integer read");
 704   next_record (dtp, 1);
 705   return;
 706
 707  overflow:
 708   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 709                   "Value overflowed during integer read");
 710   next_record (dtp, 1);
 711
 712 }
 713
 714
 715 /* read_radix()-- This function reads values for non-decimal radixes.
 716  * The difference here is that we treat the values here as unsigned
 717  * values for the purposes of overflow.  If minus sign is present and
 718  * the top bit is set, the value will be incorrect. */
 719
 720 void
 721 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 722             int radix)
 723 {
 724   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 725   GFC_INTEGER_LARGEST v;
 726   int w, negative;
 727   char c, *p;
 728
 729   w = f->u.w;
 730
 731   p = read_block_form (dtp, &w);
 732
 733   if (p == NULL)
 734     return;
 735
 736   p = eat_leading_spaces (&w, p);
 737   if (w == 0)
 738     {
 739       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 740       return;
 741     }
 742
 743   maxv = max_value (length, 0);
 744   maxv_r = maxv / radix;
 745
 746   negative = 0;
 747   value = 0;
 748
 749   switch (*p)
 750     {
 751     case '-':
 752       negative = 1;
 753       /* Fall through */
 754
 755     case '+':
 756       p++;
 757       if (--w == 0)
 758         goto bad;
 759       /* Fall through */
 760
 761     default:
 762       break;
 763     }
 764
 765   /* At this point we have a digit-string */
 766   value = 0;
 767
 768   for (;;)
 769     {
 770       c = next_char (dtp, &p, &w);
 771       if (c == '\0')
 772         break;
 773       if (c == ' ')
 774         {
 775           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 776           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 777         }
 778
 779       switch (radix)
 780         {
 781         case 2:
 782           if (c < '0' || c > '1')
 783             goto bad;
 784           break;
 785
 786         case 8:
 787           if (c < '0' || c > '7')
 788             goto bad;
 789           break;
 790
 791         case 16:
 792           switch (c)
 793             {
 794             case '0':
 795             case '1':
 796             case '2':
 797             case '3':
 798             case '4':
 799             case '5':
 800             case '6':
 801             case '7':
 802             case '8':
 803             case '9':
 804               break;
 805
 806             case 'a':
 807             case 'b':
 808             case 'c':
 809             case 'd':
 810             case 'e':
 811             case 'f':
 812               c = c - 'a' + '9' + 1;
 813               break;
 814
 815             case 'A':
 816             case 'B':
 817             case 'C':
 818             case 'D':
 819             case 'E':
 820             case 'F':
 821               c = c - 'A' + '9' + 1;
 822               break;
 823
 824             default:
 825               goto bad;
 826             }
 827
 828           break;
 829         }
 830
 831       if (value > maxv_r)
 832         goto overflow;
 833
 834       c -= '0';
 835       value = radix * value;
 836
 837       if (maxv - c < value)
 838         goto overflow;
 839       value += c;
 840     }
 841
 842   v = value;
 843   if (negative)
 844     v = -v;
 845
 846   set_integer (dest, v, length);
 847   return;
 848
 849  bad:
 850   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 851                   "Bad value during integer read");
 852   next_record (dtp, 1);
 853   return;
 854
 855  overflow:
 856   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 857                   "Value overflowed during integer read");
 858   next_record (dtp, 1);
 859
 860 }
 861
 862
 863 /* read_f()-- Read a floating point number with F-style editing, which
 864    is what all of the other floating point descriptors behave as.  The
 865    tricky part is that optional spaces are allowed after an E or D,
 866    and the implicit decimal point if a decimal point is not present in
 867    the input.  */
 868
 869 void
 870 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 871 {
 872   int w, seen_dp, exponent;
 873   int exponent_sign;
 874   const char *p;
 875   char *buffer;
 876   char *out;
 877   int seen_int_digit; /* Seen a digit before the decimal point?  */
 878   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 879
 880   seen_dp = 0;
 881   seen_int_digit = 0;
 882   seen_dec_digit = 0;
 883   exponent_sign = 1;
 884   exponent = 0;
 885   w = f->u.w;
 886
 887   /* Read in the next block.  */
 888   p = read_block_form (dtp, &w);
 889   if (p == NULL)
 890     return;
 891   p = eat_leading_spaces (&w, (char*) p);
 892   if (w == 0)
 893     goto zero;
 894
 895   /* In this buffer we're going to re-format the number cleanly to be parsed
 896      by convert_real in the end; this assures we're using strtod from the
 897      C library for parsing and thus probably get the best accuracy possible.
 898      This process may add a '+0.0' in front of the number as well as change the
 899      exponent because of an implicit decimal point or the like.  Thus allocating
 900      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 901      original buffer had should be enough.  */
 902   buffer = gfc_alloca (w + 11);
 903   out = buffer;
 904
 905   /* Optional sign */
 906   if (*p == '-' || *p == '+')
 907     {
 908       if (*p == '-')
 909         *(out++) = '-';
 910       ++p;
 911       --w;
 912     }
 913
 914   p = eat_leading_spaces (&w, (char*) p);
 915   if (w == 0)
 916     goto zero;
 917
 918   /* Check for Infinity or NaN.  */
 919   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 920     {
 921       int seen_paren = 0;
 922       char *save = out;
 923
 924       /* Scan through the buffer keeping track of spaces and parenthesis. We
 925          null terminate the string as soon as we see a left paren or if we are
 926          BLANK_NULL mode.  Leading spaces have already been skipped above,
 927          trailing spaces are ignored by converting to '\0'. A space
 928          between "NaN" and the optional perenthesis is not permitted.  */
 929       while (w > 0)
 930         {
 931           *out = tolower (*p);
 932           switch (*p)
 933             {
 934             case ' ':
 935               if (dtp->u.p.blank_status == BLANK_ZERO)
 936                 {
 937                   *out = '0';
 938                   break;
 939                 }
 940               *out = '\0';
 941               if (seen_paren == 1)
 942                 goto bad_float;
 943               break;
 944             case '(':
 945               seen_paren++;
 946               *out = '\0';
 947               break;
 948             case ')':
 949               if (seen_paren++ != 1)
 950                 goto bad_float;
 951               break;
 952             default:
 953               if (!isalnum (*out))
 954                 goto bad_float;
 955             }
 956           --w;
 957           ++p;
 958           ++out;
 959         }
 960
 961       *out = '\0';
 962
 963       if (seen_paren != 0 && seen_paren != 2)
 964         goto bad_float;
 965
 966       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 967         {
 968            if (seen_paren)
 969              goto bad_float;
 970         }
 971       else if (strcmp (save, "nan") != 0)
 972         goto bad_float;
 973
 974       convert_infnan (dtp, dest, buffer, length);
 975       return;
 976     }
 977
 978   /* Process the mantissa string.  */
 979   while (w > 0)
 980     {
 981       switch (*p)
 982         {
 983         case ',':
 984           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 985             goto bad_float;
 986           /* Fall through.  */
 987         case '.':
 988           if (seen_dp)
 989             goto bad_float;
 990           if (!seen_int_digit)
 991             *(out++) = '0';
 992           *(out++) = '.';
 993           seen_dp = 1;
 994           break;
 995
 996         case ' ':
 997           if (dtp->u.p.blank_status == BLANK_ZERO)
 998             {
 999               *(out++) = '0';
1000               goto found_digit;
1001             }
1002           else if (dtp->u.p.blank_status == BLANK_NULL)
1003             break;
1004           else
1005             /* TODO: Should we check instead that there are only trailing
1006                blanks here, as is done below for exponents?  */
1007             goto done;
1008           /* Fall through.  */
1009         case '0':
1010         case '1':
1011         case '2':
1012         case '3':
1013         case '4':
1014         case '5':
1015         case '6':
1016         case '7':
1017         case '8':
1018         case '9':
1019           *(out++) = *p;
1020 found_digit:
1021           if (!seen_dp)
1022             seen_int_digit = 1;
1023           else
1024             seen_dec_digit = 1;
1025           break;
1026
1027         case '-':
1028         case '+':
1029           goto exponent;
1030
1031         case 'e':
1032         case 'E':
1033         case 'd':
1034         case 'D':
1035           ++p;
1036           --w;
1037           goto exponent;
1038
1039         default:
1040           goto bad_float;
1041         }
1042
1043       ++p;
1044       --w;
1045     }
1046
1047   /* No exponent has been seen, so we use the current scale factor.  */
1048   exponent = - dtp->u.p.scale_factor;
1049   goto done;
1050
1051   /* At this point the start of an exponent has been found.  */
1052 exponent:
1053   p = eat_leading_spaces (&w, (char*) p);
1054   if (*p == '-' || *p == '+')
1055     {
1056       if (*p == '-')
1057         exponent_sign = -1;
1058       ++p;
1059       --w;
1060     }
1061
1062   /* At this point a digit string is required.  We calculate the value
1063      of the exponent in order to take account of the scale factor and
1064      the d parameter before explict conversion takes place.  */
1065
1066   if (w == 0)
1067     goto bad_float;
1068
1069   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1070     {
1071       while (w > 0 && isdigit (*p))
1072         {
1073           exponent *= 10;
1074           exponent += *p - '0';
1075           ++p;
1076           --w;
1077         }
1078
1079       /* Only allow trailing blanks.  */
1080       while (w > 0)
1081         {
1082           if (*p != ' ')
1083             goto bad_float;
1084           ++p;
1085           --w;
1086         }
1087     }
1088   else  /* BZ or BN status is enabled.  */
1089     {
1090       while (w > 0)
1091         {
1092           if (*p == ' ')
1093             {
1094               if (dtp->u.p.blank_status == BLANK_ZERO)
1095                 exponent *= 10;
1096               else
1097                 assert (dtp->u.p.blank_status == BLANK_NULL);
1098             }
1099           else if (!isdigit (*p))
1100             goto bad_float;
1101           else
1102             {
1103               exponent *= 10;
1104               exponent += *p - '0';
1105             }
1106
1107           ++p;
1108           --w;
1109         }
1110     }
1111
1112   exponent *= exponent_sign;
1113
1114 done:
1115   /* Use the precision specified in the format if no decimal point has been
1116      seen.  */
1117   if (!seen_dp)
1118     exponent -= f->u.real.d;
1119
1120   /* Output a trailing '0' after decimal point if not yet found.  */
1121   if (seen_dp && !seen_dec_digit)
1122     *(out++) = '0';
1123   /* Handle input of style "E+NN" by inserting a 0 for the
1124      significand.  */
1125   else if (!seen_int_digit && !seen_dec_digit)
1126     {
1127       notify_std (&dtp->common, GFC_STD_LEGACY,
1128                   "REAL input of style 'E+NN'");
1129       *(out++) = '0';
1130     }
1131
1132   /* Print out the exponent to finish the reformatted number.  Maximum 4
1133      digits for the exponent.  */
1134   if (exponent != 0)
1135     {
1136       int dig;
1137
1138       *(out++) = 'e';
1139       if (exponent < 0)
1140         {
1141           *(out++) = '-';
1142           exponent = - exponent;
1143         }
1144
1145       assert (exponent < 10000);
1146       for (dig = 3; dig >= 0; --dig)
1147         {
1148           out[dig] = (char) ('0' + exponent % 10);
1149           exponent /= 10;
1150         }
1151       out += 4;
1152     }
1153   *(out++) = '\0';
1154
1155   /* Do the actual conversion.  */
1156   convert_real (dtp, dest, buffer, length);
1157
1158   return;
1159
1160   /* The value read is zero.  */
1161 zero:
1162   switch (length)
1163     {
1164       case 4:
1165         *((GFC_REAL_4 *) dest) = 0.0;
1166         break;
1167
1168       case 8:
1169         *((GFC_REAL_8 *) dest) = 0.0;
1170         break;
1171
1172 #ifdef HAVE_GFC_REAL_10
1173       case 10:
1174         *((GFC_REAL_10 *) dest) = 0.0;
1175         break;
1176 #endif
1177
1178 #ifdef HAVE_GFC_REAL_16
1179       case 16:
1180         *((GFC_REAL_16 *) dest) = 0.0;
1181         break;
1182 #endif
1183
1184       default:
1185         internal_error (&dtp->common, "Unsupported real kind during IO");
1186     }
1187   return;
1188
1189 bad_float:
1190   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1191                   "Bad value during floating point read");
1192   next_record (dtp, 1);
1193   return;
1194 }
1195
1196
1197 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1198  * and never look at it. */
1199
1200 void
1201 read_x (st_parameter_dt *dtp, int n)
1202 {
1203   int length, q, q2;
1204
1205   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1206        && dtp->u.p.current_unit->bytes_left < n)
1207     n = dtp->u.p.current_unit->bytes_left;
1208
1209   if (n == 0)
1210     return;
1211
1212   length = n;
1213
1214   if (is_internal_unit (dtp))
1215     {
1216       mem_alloc_r (dtp->u.p.current_unit->s, &length);
1217       if (unlikely (length < n))
1218         n = length;
1219       goto done;
1220     }
1221
1222   if (dtp->u.p.sf_seen_eor)
1223     return;
1224
1225   n = 0;
1226   while (n < length)
1227     {
1228       q = fbuf_getc (dtp->u.p.current_unit);
1229       if (q == EOF)
1230         break;
1231       else if (q == '\n' || q == '\r')
1232         {
1233           /* Unexpected end of line. Set the position.  */
1234           dtp->u.p.sf_seen_eor = 1;
1235
1236           /* If we see an EOR during non-advancing I/O, we need to skip
1237              the rest of the I/O statement.  Set the corresponding flag.  */
1238           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1239             dtp->u.p.eor_condition = 1;
1240
1241           /* If we encounter a CR, it might be a CRLF.  */
1242           if (q == '\r') /* Probably a CRLF */
1243             {
1244               /* See if there is an LF.  */
1245               q2 = fbuf_getc (dtp->u.p.current_unit);
1246               if (q2 == '\n')
1247                 dtp->u.p.sf_seen_eor = 2;
1248               else if (q2 != EOF) /* Oops, seek back.  */
1249                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1250             }
1251           goto done;
1252         }
1253       n++;
1254     }
1255
1256  done:
1257   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1258     dtp->u.p.size_used += (GFC_IO_INT) n;
1259   dtp->u.p.current_unit->bytes_left -= n;
1260   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1261 }
1262