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