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.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.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.decimal_status == DECIMAL_COMMA && *p == ',')
 844             *p = '.';
 845           /* Fall through */
 846         case '.':
 847           if (seen_dp)
 848             goto bad_float;
 849           seen_dp = 1;
 850           /* Fall through */
 851
 852         case '0':
 853         case '1':
 854         case '2':
 855         case '3':
 856         case '4':
 857         case '5':
 858         case '6':
 859         case '7':
 860         case '8':
 861         case '9':
 862         case ' ':
 863           ndigits++;
 864           p++;
 865           w--;
 866           break;
 867
 868         case '-':
 869           exponent_sign = -1;
 870           /* Fall through */
 871
 872         case '+':
 873           p++;
 874           w--;
 875           goto exp2;
 876
 877         case 'd':
 878         case 'e':
 879         case 'D':
 880         case 'E':
 881           p++;
 882           w--;
 883           goto exp1;
 884
 885         default:
 886           goto bad_float;
 887         }
 888     }
 889
 890   /* No exponent has been seen, so we use the current scale factor */
 891   exponent = -dtp->u.p.scale_factor;
 892   goto done;
 893
 894  bad_float:
 895   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 896                   "Bad value during floating point read");
 897   next_record (dtp, 1);
 898   return;
 899
 900   /* The value read is zero */
 901  zero:
 902   switch (length)
 903     {
 904       case 4:
 905         *((GFC_REAL_4 *) dest) = 0;
 906         break;
 907
 908       case 8:
 909         *((GFC_REAL_8 *) dest) = 0;
 910         break;
 911
 912 #ifdef HAVE_GFC_REAL_10
 913       case 10:
 914         *((GFC_REAL_10 *) dest) = 0;
 915         break;
 916 #endif
 917
 918 #ifdef HAVE_GFC_REAL_16
 919       case 16:
 920         *((GFC_REAL_16 *) dest) = 0;
 921         break;
 922 #endif
 923
 924       default:
 925         internal_error (&dtp->common, "Unsupported real kind during IO");
 926     }
 927   return;
 928
 929   /* At this point the start of an exponent has been found */
 930  exp1:
 931   while (w > 0 && *p == ' ')
 932     {
 933       w--;
 934       p++;
 935     }
 936
 937   switch (*p)
 938     {
 939     case '-':
 940       exponent_sign = -1;
 941       /* Fall through */
 942
 943     case '+':
 944       p++;
 945       w--;
 946       break;
 947     }
 948
 949   if (w == 0)
 950     goto bad_float;
 951
 952   /* At this point a digit string is required.  We calculate the value
 953      of the exponent in order to take account of the scale factor and
 954      the d parameter before explict conversion takes place. */
 955  exp2:
 956   if (!isdigit (*p))
 957     goto bad_float;
 958
 959   exponent = *p - '0';
 960   p++;
 961   w--;
 962
 963   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
 964     {
 965       while (w > 0 && isdigit (*p))
 966         {
 967           exponent = 10 * exponent + *p - '0';
 968           p++;
 969           w--;
 970         }
 971
 972       /* Only allow trailing blanks */
 973
 974       while (w > 0)
 975         {
 976           if (*p != ' ')
 977           goto bad_float;
 978           p++;
 979           w--;
 980         }
 981     }
 982   else  /* BZ or BN status is enabled */
 983     {
 984       while (w > 0)
 985         {
 986           if (*p == ' ')
 987             {
 988               if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
 989               if (dtp->u.p.blank_status == BLANK_NULL)
 990                 {
 991                   p++;
 992                   w--;
 993                   continue;
 994                 }
 995             }
 996           else if (!isdigit (*p))
 997             goto bad_float;
 998
 999           exponent = 10 * exponent + *p - '0';
1000           p++;
1001           w--;
1002         }
1003     }
1004
1005   exponent = exponent * exponent_sign;
1006
1007  done:
1008   /* Use the precision specified in the format if no decimal point has been
1009      seen.  */
1010   if (!seen_dp)
1011     exponent -= f->u.real.d;
1012
1013   if (exponent > 0)
1014     {
1015       edigits = 2;
1016       i = exponent;
1017     }
1018   else
1019     {
1020       edigits = 3;
1021       i = -exponent;
1022     }
1023
1024   while (i >= 10)
1025     {
1026       i /= 10;
1027       edigits++;
1028     }
1029
1030   i = ndigits + edigits + 1;
1031   if (val_sign < 0)
1032     i++;
1033
1034   if (i < SCRATCH_SIZE)
1035     buffer = scratch;
1036   else
1037     buffer = get_mem (i);
1038
1039   /* Reformat the string into a temporary buffer.  As we're using atof it's
1040      easiest to just leave the decimal point in place.  */
1041   p = buffer;
1042   if (val_sign < 0)
1043     *(p++) = '-';
1044   for (; ndigits > 0; ndigits--)
1045     {
1046       if (*digits == ' ')
1047         {
1048           if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
1049           if (dtp->u.p.blank_status == BLANK_NULL)
1050             {
1051               digits++;
1052               continue;
1053             }
1054         }
1055       *p = *digits;
1056       p++;
1057       digits++;
1058     }
1059   *(p++) = 'e';
1060   sprintf (p, "%d", exponent);
1061
1062   /* Do the actual conversion.  */
1063   convert_real (dtp, dest, buffer, length);
1064
1065   if (buffer != scratch)
1066      free_mem (buffer);
1067
1068 }
1069
1070
1071 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1072  * and never look at it. */
1073
1074 void
1075 read_x (st_parameter_dt * dtp, int n)
1076 {
1077   if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp))
1078       && dtp->u.p.current_unit->bytes_left < n)
1079     n = dtp->u.p.current_unit->bytes_left;
1080
1081   dtp->u.p.sf_read_comma = 0;
1082   if (n > 0)
1083     read_sf (dtp, &n, 1);
1084   dtp->u.p.sf_read_comma = 1;
1085   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1086 }
1087