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