libgfortran/io/read.c

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