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