libgfortran/io/read.c

   1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008 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 95 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 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "io.h"
  32 #include <string.h>
  33 #include <errno.h>
  34 #include <ctype.h>
  35 #include <stdlib.h>
  36 #include <assert.h>
  37
  38 typedef unsigned char uchar;
  39
  40 /* read.c -- Deal with formatted reads */
  41
  42
  43 /* set_integer()-- All of the integer assignments come here to
  44  * actually place the value into memory.  */
  45
  46 void
  47 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
  48 {
  49   switch (length)
  50     {
  51 #ifdef HAVE_GFC_INTEGER_16
  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_value()-- Given a length (kind), return the maximum signed or
  90  * unsigned value */
  91
  92 GFC_UINTEGER_LARGEST
  93 max_value (int length, int signed_flag)
  94 {
  95   GFC_UINTEGER_LARGEST value;
  96 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
  97   int n;
  98 #endif
  99
 100   switch (length)
 101     {
 102 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
 103     case 16:
 104     case 10:
 105       value = 1;
 106       for (n = 1; n < 4 * length; n++)
 107         value = (value << 2) + 3;
 108       if (! signed_flag)
 109         value = 2*value+1;
 110       break;
 111 #endif
 112     case 8:
 113       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
 114       break;
 115     case 4:
 116       value = signed_flag ? 0x7fffffff : 0xffffffff;
 117       break;
 118     case 2:
 119       value = signed_flag ? 0x7fff : 0xffff;
 120       break;
 121     case 1:
 122       value = signed_flag ? 0x7f : 0xff;
 123       break;
 124     default:
 125       internal_error (NULL, "Bad integer kind");
 126     }
 127
 128   return value;
 129 }
 130
 131
 132 /* convert_real()-- Convert a character representation of a floating
 133  * point number to the machine number.  Returns nonzero if there is a
 134  * range problem during conversion.  TODO: handle not-a-numbers and
 135  * infinities.  */
 136
 137 int
 138 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
 139 {
 140   errno = 0;
 141
 142   switch (length)
 143     {
 144     case 4:
 145       *((GFC_REAL_4*) dest) =
 146 #if defined(HAVE_STRTOF)
 147         strtof (buffer, NULL);
 148 #else
 149         (GFC_REAL_4) strtod (buffer, NULL);
 150 #endif
 151       break;
 152
 153     case 8:
 154       *((GFC_REAL_8*) dest) = strtod (buffer, NULL);
 155       break;
 156
 157 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
 158     case 10:
 159       *((GFC_REAL_10*) dest) = strtold (buffer, NULL);
 160       break;
 161 #endif
 162
 163 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
 164     case 16:
 165       *((GFC_REAL_16*) dest) = strtold (buffer, NULL);
 166       break;
 167 #endif
 168
 169     default:
 170       internal_error (&dtp->common, "Unsupported real kind during IO");
 171     }
 172
 173   if (errno == EINVAL)
 174     {
 175       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 176                       "Error during floating point read");
 177       next_record (dtp, 1);
 178       return 1;
 179     }
 180
 181   return 0;
 182 }
 183
 184
 185 /* read_l()-- Read a logical value */
 186
 187 void
 188 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 189 {
 190   char *p;
 191   int w;
 192
 193   w = f->u.w;
 194
 195   p = read_block_form (dtp, &w);
 196
 197   if (p == NULL)
 198     return;
 199
 200   while (*p == ' ')
 201     {
 202       if (--w == 0)
 203         goto bad;
 204       p++;
 205     }
 206
 207   if (*p == '.')
 208     {
 209       if (--w == 0)
 210         goto bad;
 211       p++;
 212     }
 213
 214   switch (*p)
 215     {
 216     case 't':
 217     case 'T':
 218       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
 219       break;
 220     case 'f':
 221     case 'F':
 222       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 223       break;
 224     default:
 225     bad:
 226       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 227                       "Bad value on logical read");
 228       next_record (dtp, 1);
 229       break;
 230     }
 231 }
 232
 233
 234 static gfc_char4_t
 235 read_utf8 (st_parameter_dt *dtp, int *nbytes)
 236 {
 237   static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
 238   static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
 239   int i, nb, nread;
 240   gfc_char4_t c;
 241   char *s;
 242
 243   *nbytes = 1;
 244
 245   s = read_block_form (dtp, nbytes);
 246   if (s == NULL)
 247     return 0;
 248
 249   /* If this is a short read, just return.  */
 250   if (*nbytes == 0)
 251     return 0;
 252
 253   c = (uchar) s[0];
 254   if (c < 0x80)
 255     return c;
 256
 257   /* The number of leading 1-bits in the first byte indicates how many
 258      bytes follow.  */
 259   for (nb = 2; nb < 7; nb++)
 260     if ((c & ~masks[nb-1]) == patns[nb-1])
 261       goto found;
 262   goto invalid;
 263
 264  found:
 265   c = (c & masks[nb-1]);
 266   nread = nb - 1;
 267
 268   s = read_block_form (dtp, &nread);
 269   if (s == NULL)
 270     return 0;
 271   /* Decode the bytes read.  */
 272   for (i = 1; i < nb; i++)
 273     {
 274       gfc_char4_t n = *s++;
 275
 276       if ((n & 0xC0) != 0x80)
 277         goto invalid;
 278
 279       c = ((c << 6) + (n & 0x3F));
 280     }
 281
 282   /* Make sure the shortest possible encoding was used.  */
 283   if (c <=      0x7F && nb > 1) goto invalid;
 284   if (c <=     0x7FF && nb > 2) goto invalid;
 285   if (c <=    0xFFFF && nb > 3) goto invalid;
 286   if (c <=  0x1FFFFF && nb > 4) goto invalid;
 287   if (c <= 0x3FFFFFF && nb > 5) goto invalid;
 288
 289   /* Make sure the character is valid.  */
 290   if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
 291     goto invalid;
 292
 293   return c;
 294
 295  invalid:
 296   generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
 297   return (gfc_char4_t) '?';
 298 }
 299
 300
 301 static void
 302 read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 303 {
 304   gfc_char4_t c;
 305   char *dest;
 306   int nbytes;
 307   int i, j;
 308
 309   len = (width < len) ? len : width;
 310
 311   dest = (char *) p;
 312
 313   /* Proceed with decoding one character at a time.  */
 314   for (j = 0; j < len; j++, dest++)
 315     {
 316       c = read_utf8 (dtp, &nbytes);
 317
 318       /* Check for a short read and if so, break out.  */
 319       if (nbytes == 0)
 320         break;
 321
 322       *dest = c > 255 ? '?' : (uchar) c;
 323     }
 324
 325   /* If there was a short read, pad the remaining characters.  */
 326   for (i = j; i < len; i++)
 327     *dest++ = ' ';
 328   return;
 329 }
 330
 331 static void
 332 read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 333 {
 334   char *s;
 335   int m, n;
 336
 337   s = read_block_form (dtp, &width);
 338
 339   if (s == NULL)
 340     return;
 341   if (width > len)
 342      s += (width - len);
 343
 344   m = (width > len) ? len : width;
 345   memcpy (p, s, m);
 346
 347   n = len - width;
 348   if (n > 0)
 349     memset (p + m, ' ', n);
 350 }
 351
 352
 353 static void
 354 read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
 355 {
 356   gfc_char4_t *dest;
 357   int nbytes;
 358   int i, j;
 359
 360   len = (width < len) ? len : width;
 361
 362   dest = (gfc_char4_t *) p;
 363
 364   /* Proceed with decoding one character at a time.  */
 365   for (j = 0; j < len; j++, dest++)
 366     {
 367       *dest = read_utf8 (dtp, &nbytes);
 368
 369       /* Check for a short read and if so, break out.  */
 370       if (nbytes == 0)
 371         break;
 372     }
 373
 374   /* If there was a short read, pad the remaining characters.  */
 375   for (i = j; i < len; i++)
 376     *dest++ = (gfc_char4_t) ' ';
 377   return;
 378 }
 379
 380
 381 static void
 382 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 383 {
 384   char *s;
 385   gfc_char4_t *dest;
 386   int m, n;
 387
 388   s = read_block_form (dtp, &width);
 389
 390   if (s == NULL)
 391     return;
 392   if (width > len)
 393      s += (width - len);
 394
 395   m = ((int) width > len) ? len : (int) width;
 396
 397   dest = (gfc_char4_t *) p;
 398
 399   for (n = 0; n < m; n++, dest++, s++)
 400     *dest = (unsigned char ) *s;
 401
 402   for (n = 0; n < len - (int) width; n++, dest++)
 403     *dest = (unsigned char) ' ';
 404 }
 405
 406
 407 /* read_a()-- Read a character record into a KIND=1 character destination,
 408    processing UTF-8 encoding if necessary.  */
 409
 410 void
 411 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 412 {
 413   int wi;
 414   int w;
 415
 416   wi = f->u.w;
 417   if (wi == -1) /* '(A)' edit descriptor  */
 418     wi = length;
 419   w = wi;
 420
 421   /* Read in w characters, treating comma as not a separator.  */
 422   dtp->u.p.sf_read_comma = 0;
 423
 424   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 425     read_utf8_char1 (dtp, p, length, w);
 426   else
 427     read_default_char1 (dtp, p, length, w);
 428
 429   dtp->u.p.sf_read_comma =
 430     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 431 }
 432
 433
 434 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
 435    processing UTF-8 encoding if necessary.  */
 436
 437 void
 438 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 439 {
 440   int w;
 441
 442   w = f->u.w;
 443   if (w == -1) /* '(A)' edit descriptor  */
 444     w = length;
 445
 446   /* Read in w characters, treating comma as not a separator.  */
 447   dtp->u.p.sf_read_comma = 0;
 448
 449   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 450     read_utf8_char4 (dtp, p, length, w);
 451   else
 452     read_default_char4 (dtp, p, length, w);
 453
 454   dtp->u.p.sf_read_comma =
 455     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 456 }
 457
 458 /* eat_leading_spaces()-- Given a character pointer and a width,
 459  * ignore the leading spaces.  */
 460
 461 static char *
 462 eat_leading_spaces (int *width, char *p)
 463 {
 464   for (;;)
 465     {
 466       if (*width == 0 || *p != ' ')
 467         break;
 468
 469       (*width)--;
 470       p++;
 471     }
 472
 473   return p;
 474 }
 475
 476
 477 static char
 478 next_char (st_parameter_dt *dtp, char **p, int *w)
 479 {
 480   char c, *q;
 481
 482   if (*w == 0)
 483     return '\0';
 484
 485   q = *p;
 486   c = *q++;
 487   *p = q;
 488
 489   (*w)--;
 490
 491   if (c != ' ')
 492     return c;
 493   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
 494     return ' ';  /* return a blank to signal a null */
 495
 496   /* At this point, the rest of the field has to be trailing blanks */
 497
 498   while (*w > 0)
 499     {
 500       if (*q++ != ' ')
 501         return '?';
 502       (*w)--;
 503     }
 504
 505   *p = q;
 506   return '\0';
 507 }
 508
 509
 510 /* read_decimal()-- Read a decimal integer value.  The values here are
 511  * signed values. */
 512
 513 void
 514 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 515 {
 516   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 517   GFC_INTEGER_LARGEST v;
 518   int w, negative;
 519   char c, *p;
 520
 521   w = f->u.w;
 522
 523   p = read_block_form (dtp, &w);
 524
 525   if (p == NULL)
 526     return;
 527
 528   p = eat_leading_spaces (&w, p);
 529   if (w == 0)
 530     {
 531       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 532       return;
 533     }
 534
 535   maxv = max_value (length, 1);
 536   maxv_10 = maxv / 10;
 537
 538   negative = 0;
 539   value = 0;
 540
 541   switch (*p)
 542     {
 543     case '-':
 544       negative = 1;
 545       /* Fall through */
 546
 547     case '+':
 548       p++;
 549       if (--w == 0)
 550         goto bad;
 551       /* Fall through */
 552
 553     default:
 554       break;
 555     }
 556
 557   /* At this point we have a digit-string */
 558   value = 0;
 559
 560   for (;;)
 561     {
 562       c = next_char (dtp, &p, &w);
 563       if (c == '\0')
 564         break;
 565
 566       if (c == ' ')
 567         {
 568           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 569           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 570         }
 571
 572       if (c < '0' || c > '9')
 573         goto bad;
 574
 575       if (value > maxv_10 && compile_options.range_check == 1)
 576         goto overflow;
 577
 578       c -= '0';
 579       value = 10 * value;
 580
 581       if (value > maxv - c && compile_options.range_check == 1)
 582         goto overflow;
 583       value += c;
 584     }
 585
 586   v = value;
 587   if (negative)
 588     v = -v;
 589
 590   set_integer (dest, v, length);
 591   return;
 592
 593  bad:
 594   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 595                   "Bad value during integer read");
 596   next_record (dtp, 1);
 597   return;
 598
 599  overflow:
 600   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 601                   "Value overflowed during integer read");
 602   next_record (dtp, 1);
 603
 604 }
 605
 606
 607 /* read_radix()-- This function reads values for non-decimal radixes.
 608  * The difference here is that we treat the values here as unsigned
 609  * values for the purposes of overflow.  If minus sign is present and
 610  * the top bit is set, the value will be incorrect. */
 611
 612 void
 613 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 614             int radix)
 615 {
 616   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 617   GFC_INTEGER_LARGEST v;
 618   int w, negative;
 619   char c, *p;
 620
 621   w = f->u.w;
 622
 623   p = read_block_form (dtp, &w);
 624
 625   if (p == NULL)
 626     return;
 627
 628   p = eat_leading_spaces (&w, p);
 629   if (w == 0)
 630     {
 631       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 632       return;
 633     }
 634
 635   maxv = max_value (length, 0);
 636   maxv_r = maxv / radix;
 637
 638   negative = 0;
 639   value = 0;
 640
 641   switch (*p)
 642     {
 643     case '-':
 644       negative = 1;
 645       /* Fall through */
 646
 647     case '+':
 648       p++;
 649       if (--w == 0)
 650         goto bad;
 651       /* Fall through */
 652
 653     default:
 654       break;
 655     }
 656
 657   /* At this point we have a digit-string */
 658   value = 0;
 659
 660   for (;;)
 661     {
 662       c = next_char (dtp, &p, &w);
 663       if (c == '\0')
 664         break;
 665       if (c == ' ')
 666         {
 667           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 668           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 669         }
 670
 671       switch (radix)
 672         {
 673         case 2:
 674           if (c < '0' || c > '1')
 675             goto bad;
 676           break;
 677
 678         case 8:
 679           if (c < '0' || c > '7')
 680             goto bad;
 681           break;
 682
 683         case 16:
 684           switch (c)
 685             {
 686             case '0':
 687             case '1':
 688             case '2':
 689             case '3':
 690             case '4':
 691             case '5':
 692             case '6':
 693             case '7':
 694             case '8':
 695             case '9':
 696               break;
 697
 698             case 'a':
 699             case 'b':
 700             case 'c':
 701             case 'd':
 702             case 'e':
 703             case 'f':
 704               c = c - 'a' + '9' + 1;
 705               break;
 706
 707             case 'A':
 708             case 'B':
 709             case 'C':
 710             case 'D':
 711             case 'E':
 712             case 'F':
 713               c = c - 'A' + '9' + 1;
 714               break;
 715
 716             default:
 717               goto bad;
 718             }
 719
 720           break;
 721         }
 722
 723       if (value > maxv_r)
 724         goto overflow;
 725
 726       c -= '0';
 727       value = radix * value;
 728
 729       if (maxv - c < value)
 730         goto overflow;
 731       value += c;
 732     }
 733
 734   v = value;
 735   if (negative)
 736     v = -v;
 737
 738   set_integer (dest, v, length);
 739   return;
 740
 741  bad:
 742   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 743                   "Bad value during integer read");
 744   next_record (dtp, 1);
 745   return;
 746
 747  overflow:
 748   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 749                   "Value overflowed during integer read");
 750   next_record (dtp, 1);
 751
 752 }
 753
 754
 755 /* read_f()-- Read a floating point number with F-style editing, which
 756    is what all of the other floating point descriptors behave as.  The
 757    tricky part is that optional spaces are allowed after an E or D,
 758    and the implicit decimal point if a decimal point is not present in
 759    the input.  */
 760
 761 void
 762 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 763 {
 764   int w, seen_dp, exponent;
 765   int exponent_sign;
 766   const char *p;
 767   char *buffer;
 768   char *out;
 769   int seen_int_digit; /* Seen a digit before the decimal point?  */
 770   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 771
 772   seen_dp = 0;
 773   seen_int_digit = 0;
 774   seen_dec_digit = 0;
 775   exponent_sign = 1;
 776   exponent = 0;
 777   w = f->u.w;
 778
 779   /* Read in the next block.  */
 780   p = read_block_form (dtp, &w);
 781   if (p == NULL)
 782     return;
 783   p = eat_leading_spaces (&w, (char*) p);
 784   if (w == 0)
 785     goto zero;
 786
 787   /* In this buffer we're going to re-format the number cleanly to be parsed
 788      by convert_real in the end; this assures we're using strtod from the
 789      C library for parsing and thus probably get the best accuracy possible.
 790      This process may add a '+0.0' in front of the number as well as change the
 791      exponent because of an implicit decimal point or the like.  Thus allocating
 792      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 793      original buffer had should be enough.  */
 794   buffer = gfc_alloca (w + 11);
 795   out = buffer;
 796
 797   /* Optional sign */
 798   if (*p == '-' || *p == '+')
 799     {
 800       if (*p == '-')
 801         *(out++) = '-';
 802       ++p;
 803       --w;
 804     }
 805
 806   p = eat_leading_spaces (&w, (char*) p);
 807   if (w == 0)
 808     goto zero;
 809
 810   /* Process the mantissa string.  */
 811   while (w > 0)
 812     {
 813       switch (*p)
 814         {
 815         case ',':
 816           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 817             goto bad_float;
 818           /* Fall through.  */
 819         case '.':
 820           if (seen_dp)
 821             goto bad_float;
 822           if (!seen_int_digit)
 823             *(out++) = '0';
 824           *(out++) = '.';
 825           seen_dp = 1;
 826           break;
 827
 828         case ' ':
 829           if (dtp->u.p.blank_status == BLANK_ZERO)
 830             {
 831               *(out++) = '0';
 832               goto found_digit;
 833             }
 834           else if (dtp->u.p.blank_status == BLANK_NULL)
 835             break;
 836           else
 837             /* TODO: Should we check instead that there are only trailing
 838                blanks here, as is done below for exponents?  */
 839             goto done;
 840           /* Fall through.  */
 841         case '0':
 842         case '1':
 843         case '2':
 844         case '3':
 845         case '4':
 846         case '5':
 847         case '6':
 848         case '7':
 849         case '8':
 850         case '9':
 851           *(out++) = *p;
 852 found_digit:
 853           if (!seen_dp)
 854             seen_int_digit = 1;
 855           else
 856             seen_dec_digit = 1;
 857           break;
 858
 859         case '-':
 860         case '+':
 861           goto exponent;
 862
 863         case 'e':
 864         case 'E':
 865         case 'd':
 866         case 'D':
 867           ++p;
 868           --w;
 869           goto exponent;
 870
 871         default:
 872           goto bad_float;
 873         }
 874
 875       ++p;
 876       --w;
 877     }
 878
 879   /* No exponent has been seen, so we use the current scale factor.  */
 880   exponent = - dtp->u.p.scale_factor;
 881   goto done;
 882
 883   /* At this point the start of an exponent has been found.  */
 884 exponent:
 885   p = eat_leading_spaces (&w, (char*) p);
 886   if (*p == '-' || *p == '+')
 887     {
 888       if (*p == '-')
 889         exponent_sign = -1;
 890       ++p;
 891       --w;
 892     }
 893
 894   /* At this point a digit string is required.  We calculate the value
 895      of the exponent in order to take account of the scale factor and
 896      the d parameter before explict conversion takes place.  */
 897
 898   if (w == 0)
 899     goto bad_float;
 900
 901   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
 902     {
 903       while (w > 0 && isdigit (*p))
 904         {
 905           exponent *= 10;
 906           exponent += *p - '0';
 907           ++p;
 908           --w;
 909         }
 910
 911       /* Only allow trailing blanks.  */
 912       while (w > 0)
 913         {
 914           if (*p != ' ')
 915             goto bad_float;
 916           ++p;
 917           --w;
 918         }
 919     }
 920   else  /* BZ or BN status is enabled.  */
 921     {
 922       while (w > 0)
 923         {
 924           if (*p == ' ')
 925             {
 926               if (dtp->u.p.blank_status == BLANK_ZERO)
 927                 exponent *= 10;
 928               else
 929                 assert (dtp->u.p.blank_status == BLANK_NULL);
 930             }
 931           else if (!isdigit (*p))
 932             goto bad_float;
 933           else
 934             {
 935               exponent *= 10;
 936               exponent += *p - '0';
 937             }
 938
 939           ++p;
 940           --w;
 941         }
 942     }
 943
 944   exponent *= exponent_sign;
 945
 946 done:
 947   /* Use the precision specified in the format if no decimal point has been
 948      seen.  */
 949   if (!seen_dp)
 950     exponent -= f->u.real.d;
 951
 952   /* Output a trailing '0' after decimal point if not yet found.  */
 953   if (seen_dp && !seen_dec_digit)
 954     *(out++) = '0';
 955
 956   /* Print out the exponent to finish the reformatted number.  Maximum 4
 957      digits for the exponent.  */
 958   if (exponent != 0)
 959     {
 960       int dig;
 961
 962       *(out++) = 'e';
 963       if (exponent < 0)
 964         {
 965           *(out++) = '-';
 966           exponent = - exponent;
 967         }
 968
 969       assert (exponent < 10000);
 970       for (dig = 3; dig >= 0; --dig)
 971         {
 972           out[dig] = (char) ('0' + exponent % 10);
 973           exponent /= 10;
 974         }
 975       out += 4;
 976     }
 977   *(out++) = '\0';
 978
 979   /* Do the actual conversion.  */
 980   convert_real (dtp, dest, buffer, length);
 981
 982   return;
 983
 984   /* The value read is zero.  */
 985 zero:
 986   switch (length)
 987     {
 988       case 4:
 989         *((GFC_REAL_4 *) dest) = 0.0;
 990         break;
 991
 992       case 8:
 993         *((GFC_REAL_8 *) dest) = 0.0;
 994         break;
 995
 996 #ifdef HAVE_GFC_REAL_10
 997       case 10:
 998         *((GFC_REAL_10 *) dest) = 0.0;
 999         break;
1000 #endif
1001
1002 #ifdef HAVE_GFC_REAL_16
1003       case 16:
1004         *((GFC_REAL_16 *) dest) = 0.0;
1005         break;
1006 #endif
1007
1008       default:
1009         internal_error (&dtp->common, "Unsupported real kind during IO");
1010     }
1011   return;
1012
1013 bad_float:
1014   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1015                   "Bad value during floating point read");
1016   next_record (dtp, 1);
1017   return;
1018 }
1019
1020
1021 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1022  * and never look at it. */
1023
1024 void
1025 read_x (st_parameter_dt * dtp, int n)
1026 {
1027   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1028        && dtp->u.p.current_unit->bytes_left < n)
1029     n = dtp->u.p.current_unit->bytes_left;
1030
1031   dtp->u.p.sf_read_comma = 0;
1032   if (n > 0)
1033     read_sf (dtp, &n, 1);
1034   dtp->u.p.sf_read_comma = 1;
1035   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1036 }
1037