libgfortran/io/read.c

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