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 =
 444     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 445 }
 446
 447
 448 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
 449    processing UTF-8 encoding if necessary.  */
 450
 451 void
 452 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 453 {
 454   int wi;
 455   size_t w;
 456
 457   wi = f->u.w;
 458   if (wi == -1) /* '(A)' edit descriptor  */
 459     wi = length;
 460   w = wi;
 461
 462   /* Read in w characters, treating comma as not a separator.  */
 463   dtp->u.p.sf_read_comma = 0;
 464
 465   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 466     read_utf8_char4 (dtp, p, length, w);
 467   else
 468     read_default_char4 (dtp, p, length, w);
 469
 470   dtp->u.p.sf_read_comma =
 471     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 472 }
 473
 474 /* eat_leading_spaces()-- Given a character pointer and a width,
 475  * ignore the leading spaces.  */
 476
 477 static char *
 478 eat_leading_spaces (int *width, char *p)
 479 {
 480   for (;;)
 481     {
 482       if (*width == 0 || *p != ' ')
 483         break;
 484
 485       (*width)--;
 486       p++;
 487     }
 488
 489   return p;
 490 }
 491
 492
 493 static char
 494 next_char (st_parameter_dt *dtp, char **p, int *w)
 495 {
 496   char c, *q;
 497
 498   if (*w == 0)
 499     return '\0';
 500
 501   q = *p;
 502   c = *q++;
 503   *p = q;
 504
 505   (*w)--;
 506
 507   if (c != ' ')
 508     return c;
 509   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
 510     return ' ';  /* return a blank to signal a null */
 511
 512   /* At this point, the rest of the field has to be trailing blanks */
 513
 514   while (*w > 0)
 515     {
 516       if (*q++ != ' ')
 517         return '?';
 518       (*w)--;
 519     }
 520
 521   *p = q;
 522   return '\0';
 523 }
 524
 525
 526 /* read_decimal()-- Read a decimal integer value.  The values here are
 527  * signed values. */
 528
 529 void
 530 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 531 {
 532   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 533   GFC_INTEGER_LARGEST v;
 534   int w, negative;
 535   size_t wu;
 536   char c, *p;
 537
 538   wu = f->u.w;
 539
 540   p = gfc_alloca (wu);
 541
 542   if (read_block_form (dtp, p, &wu) == FAILURE)
 543     return;
 544
 545   w = wu;
 546
 547   p = eat_leading_spaces (&w, p);
 548   if (w == 0)
 549     {
 550       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 551       return;
 552     }
 553
 554   maxv = max_value (length, 1);
 555   maxv_10 = maxv / 10;
 556
 557   negative = 0;
 558   value = 0;
 559
 560   switch (*p)
 561     {
 562     case '-':
 563       negative = 1;
 564       /* Fall through */
 565
 566     case '+':
 567       p++;
 568       if (--w == 0)
 569         goto bad;
 570       /* Fall through */
 571
 572     default:
 573       break;
 574     }
 575
 576   /* At this point we have a digit-string */
 577   value = 0;
 578
 579   for (;;)
 580     {
 581       c = next_char (dtp, &p, &w);
 582       if (c == '\0')
 583         break;
 584
 585       if (c == ' ')
 586         {
 587           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 588           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 589         }
 590
 591       if (c < '0' || c > '9')
 592         goto bad;
 593
 594       if (value > maxv_10 && compile_options.range_check == 1)
 595         goto overflow;
 596
 597       c -= '0';
 598       value = 10 * value;
 599
 600       if (value > maxv - c && compile_options.range_check == 1)
 601         goto overflow;
 602       value += c;
 603     }
 604
 605   v = value;
 606   if (negative)
 607     v = -v;
 608
 609   set_integer (dest, v, length);
 610   return;
 611
 612  bad:
 613   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 614                   "Bad value during integer read");
 615   next_record (dtp, 1);
 616   return;
 617
 618  overflow:
 619   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 620                   "Value overflowed during integer read");
 621   next_record (dtp, 1);
 622
 623 }
 624
 625
 626 /* read_radix()-- This function reads values for non-decimal radixes.
 627  * The difference here is that we treat the values here as unsigned
 628  * values for the purposes of overflow.  If minus sign is present and
 629  * the top bit is set, the value will be incorrect. */
 630
 631 void
 632 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 633             int radix)
 634 {
 635   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 636   GFC_INTEGER_LARGEST v;
 637   int w, negative;
 638   char c, *p;
 639   size_t wu;
 640
 641   wu = f->u.w;
 642
 643   p = gfc_alloca (wu);
 644
 645   if (read_block_form (dtp, p, &wu) == FAILURE)
 646     return;
 647
 648   w = wu;
 649
 650   p = eat_leading_spaces (&w, p);
 651   if (w == 0)
 652     {
 653       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 654       return;
 655     }
 656
 657   maxv = max_value (length, 0);
 658   maxv_r = maxv / radix;
 659
 660   negative = 0;
 661   value = 0;
 662
 663   switch (*p)
 664     {
 665     case '-':
 666       negative = 1;
 667       /* Fall through */
 668
 669     case '+':
 670       p++;
 671       if (--w == 0)
 672         goto bad;
 673       /* Fall through */
 674
 675     default:
 676       break;
 677     }
 678
 679   /* At this point we have a digit-string */
 680   value = 0;
 681
 682   for (;;)
 683     {
 684       c = next_char (dtp, &p, &w);
 685       if (c == '\0')
 686         break;
 687       if (c == ' ')
 688         {
 689           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 690           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 691         }
 692
 693       switch (radix)
 694         {
 695         case 2:
 696           if (c < '0' || c > '1')
 697             goto bad;
 698           break;
 699
 700         case 8:
 701           if (c < '0' || c > '7')
 702             goto bad;
 703           break;
 704
 705         case 16:
 706           switch (c)
 707             {
 708             case '0':
 709             case '1':
 710             case '2':
 711             case '3':
 712             case '4':
 713             case '5':
 714             case '6':
 715             case '7':
 716             case '8':
 717             case '9':
 718               break;
 719
 720             case 'a':
 721             case 'b':
 722             case 'c':
 723             case 'd':
 724             case 'e':
 725             case 'f':
 726               c = c - 'a' + '9' + 1;
 727               break;
 728
 729             case 'A':
 730             case 'B':
 731             case 'C':
 732             case 'D':
 733             case 'E':
 734             case 'F':
 735               c = c - 'A' + '9' + 1;
 736               break;
 737
 738             default:
 739               goto bad;
 740             }
 741
 742           break;
 743         }
 744
 745       if (value > maxv_r)
 746         goto overflow;
 747
 748       c -= '0';
 749       value = radix * value;
 750
 751       if (maxv - c < value)
 752         goto overflow;
 753       value += c;
 754     }
 755
 756   v = value;
 757   if (negative)
 758     v = -v;
 759
 760   set_integer (dest, v, length);
 761   return;
 762
 763  bad:
 764   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 765                   "Bad value during integer read");
 766   next_record (dtp, 1);
 767   return;
 768
 769  overflow:
 770   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 771                   "Value overflowed during integer read");
 772   next_record (dtp, 1);
 773
 774 }
 775
 776
 777 /* read_f()-- Read a floating point number with F-style editing, which
 778    is what all of the other floating point descriptors behave as.  The
 779    tricky part is that optional spaces are allowed after an E or D,
 780    and the implicit decimal point if a decimal point is not present in
 781    the input.  */
 782
 783 void
 784 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 785 {
 786   size_t wu;
 787   int w, seen_dp, exponent;
 788   int exponent_sign, val_sign;
 789   int ndigits;
 790   int edigits;
 791   int i;
 792   char *p, *buffer;
 793   char *digits;
 794   char scratch[SCRATCH_SIZE];
 795
 796   val_sign = 1;
 797   seen_dp = 0;
 798   wu = f->u.w;
 799
 800   p = gfc_alloca (wu);
 801
 802   if (read_block_form (dtp, p, &wu) == FAILURE)
 803     return;
 804
 805   w = wu;
 806
 807   p = eat_leading_spaces (&w, p);
 808   if (w == 0)
 809     goto zero;
 810
 811   /* Optional sign */
 812
 813   if (*p == '-' || *p == '+')
 814     {
 815       if (*p == '-')
 816         val_sign = -1;
 817       p++;
 818       w--;
 819     }
 820
 821   exponent_sign = 1;
 822   p = eat_leading_spaces (&w, p);
 823   if (w == 0)
 824     goto zero;
 825
 826   /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
 827      is required at this point */
 828
 829   if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
 830       && *p != 'e' && *p != 'E')
 831     goto bad_float;
 832
 833   /* Remember the position of the first digit.  */
 834   digits = p;
 835   ndigits = 0;
 836
 837   /* Scan through the string to find the exponent.  */
 838   while (w > 0)
 839     {
 840       switch (*p)
 841         {
 842         case ',':
 843           if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA
 844                && *p == ',')
 845             *p = '.';
 846           else
 847             goto bad_float;
 848           /* Fall through */
 849         case '.':
 850           if (seen_dp)
 851             goto bad_float;
 852           seen_dp = 1;
 853           /* Fall through */
 854
 855         case '0':
 856         case '1':
 857         case '2':
 858         case '3':
 859         case '4':
 860         case '5':
 861         case '6':
 862         case '7':
 863         case '8':
 864         case '9':
 865         case ' ':
 866           ndigits++;
 867           p++;
 868           w--;
 869           break;
 870
 871         case '-':
 872           exponent_sign = -1;
 873           /* Fall through */
 874
 875         case '+':
 876           p++;
 877           w--;
 878           goto exp2;
 879
 880         case 'd':
 881         case 'e':
 882         case 'D':
 883         case 'E':
 884           p++;
 885           w--;
 886           goto exp1;
 887
 888         default:
 889           goto bad_float;
 890         }
 891     }
 892
 893   /* No exponent has been seen, so we use the current scale factor */
 894   exponent = -dtp->u.p.scale_factor;
 895   goto done;
 896
 897  bad_float:
 898   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 899                   "Bad value during floating point read");
 900   next_record (dtp, 1);
 901   return;
 902
 903   /* The value read is zero */
 904  zero:
 905   switch (length)
 906     {
 907       case 4:
 908         *((GFC_REAL_4 *) dest) = 0;
 909         break;
 910
 911       case 8:
 912         *((GFC_REAL_8 *) dest) = 0;
 913         break;
 914
 915 #ifdef HAVE_GFC_REAL_10
 916       case 10:
 917         *((GFC_REAL_10 *) dest) = 0;
 918         break;
 919 #endif
 920
 921 #ifdef HAVE_GFC_REAL_16
 922       case 16:
 923         *((GFC_REAL_16 *) dest) = 0;
 924         break;
 925 #endif
 926
 927       default:
 928         internal_error (&dtp->common, "Unsupported real kind during IO");
 929     }
 930   return;
 931
 932   /* At this point the start of an exponent has been found */
 933  exp1:
 934   while (w > 0 && *p == ' ')
 935     {
 936       w--;
 937       p++;
 938     }
 939
 940   switch (*p)
 941     {
 942     case '-':
 943       exponent_sign = -1;
 944       /* Fall through */
 945
 946     case '+':
 947       p++;
 948       w--;
 949       break;
 950     }
 951
 952   if (w == 0)
 953     goto bad_float;
 954
 955   /* At this point a digit string is required.  We calculate the value
 956      of the exponent in order to take account of the scale factor and
 957      the d parameter before explict conversion takes place. */
 958  exp2:
 959   /* Normal processing of exponent */
 960   exponent = 0;
 961   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
 962     {
 963       while (w > 0 && isdigit (*p))
 964         {
 965           exponent = 10 * exponent + *p - '0';
 966           p++;
 967           w--;
 968         }
 969
 970       /* Only allow trailing blanks */
 971
 972       while (w > 0)
 973         {
 974           if (*p != ' ')
 975             goto bad_float;
 976           p++;
 977           w--;
 978         }
 979     }
 980   else  /* BZ or BN status is enabled */
 981     {
 982       while (w > 0)
 983         {
 984           if (*p == ' ')
 985             {
 986               if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
 987               if (dtp->u.p.blank_status == BLANK_NULL)
 988                 {
 989                   p++;
 990                   w--;
 991                   continue;
 992                 }
 993             }
 994           else if (!isdigit (*p))
 995             goto bad_float;
 996
 997           exponent = 10 * exponent + *p - '0';
 998           p++;
 999           w--;
1000         }
1001     }
1002
1003   exponent = exponent * exponent_sign;
1004
1005  done:
1006   /* Use the precision specified in the format if no decimal point has been
1007      seen.  */
1008   if (!seen_dp)
1009     exponent -= f->u.real.d;
1010
1011   if (exponent > 0)
1012     {
1013       edigits = 2;
1014       i = exponent;
1015     }
1016   else
1017     {
1018       edigits = 3;
1019       i = -exponent;
1020     }
1021
1022   while (i >= 10)
1023     {
1024       i /= 10;
1025       edigits++;
1026     }
1027
1028   i = ndigits + edigits + 1;
1029   if (val_sign < 0)
1030     i++;
1031
1032   if (i < SCRATCH_SIZE)
1033     buffer = scratch;
1034   else
1035     buffer = get_mem (i);
1036
1037   /* Reformat the string into a temporary buffer.  As we're using atof it's
1038      easiest to just leave the decimal point in place.  */
1039   p = buffer;
1040   if (val_sign < 0)
1041     *(p++) = '-';
1042   for (; ndigits > 0; ndigits--)
1043     {
1044       if (*digits == ' ')
1045         {
1046           if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
1047           if (dtp->u.p.blank_status == BLANK_NULL)
1048             {
1049               digits++;
1050               continue;
1051             }
1052         }
1053       *p = *digits;
1054       p++;
1055       digits++;
1056     }
1057   *(p++) = 'e';
1058   sprintf (p, "%d", exponent);
1059
1060   /* Do the actual conversion.  */
1061   convert_real (dtp, dest, buffer, length);
1062
1063   if (buffer != scratch)
1064      free_mem (buffer);
1065
1066 }
1067
1068
1069 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1070  * and never look at it. */
1071
1072 void
1073 read_x (st_parameter_dt * dtp, int n)
1074 {
1075   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1076        && dtp->u.p.current_unit->bytes_left < n)
1077     n = dtp->u.p.current_unit->bytes_left;
1078
1079   dtp->u.p.sf_read_comma = 0;
1080   if (n > 0)
1081     read_sf (dtp, &n, 1);
1082   dtp->u.p.sf_read_comma = 1;
1083   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1084 }
1085