libgfortran/io/read.c

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