libgfortran/io/read.c

   1 /* Copyright (C) 2002-2013 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 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 signed value of size give by length argument.  */
  90
  91 GFC_UINTEGER_LARGEST
  92 si_max (int length)
  93 {
  94 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
  95   GFC_UINTEGER_LARGEST value;
  96 #endif
  97
  98   switch (length)
  99       {
 100 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
 101     case 16:
 102     case 10:
 103       value = 1;
 104       for (int n = 1; n < 4 * length; n++)
 105         value = (value << 2) + 3;
 106       return value;
 107 #endif
 108     case 8:
 109       return GFC_INTEGER_8_HUGE;
 110     case 4:
 111       return GFC_INTEGER_4_HUGE;
 112     case 2:
 113       return GFC_INTEGER_2_HUGE;
 114     case 1:
 115       return GFC_INTEGER_1_HUGE;
 116     default:
 117       internal_error (NULL, "Bad integer kind");
 118     }
 119 }
 120
 121
 122 /* convert_real()-- Convert a character representation of a floating
 123    point number to the machine number.  Returns nonzero if there is an
 124    invalid input.  Note: many architectures (e.g. IA-64, HP-PA)
 125    require that the storage pointed to by the dest argument is
 126    properly aligned for the type in question.  */
 127
 128 int
 129 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
 130 {
 131   char *endptr = NULL;
 132   int round_mode, old_round_mode;
 133
 134   switch (dtp->u.p.current_unit->round_status)
 135     {
 136       case ROUND_COMPATIBLE:
 137         /* FIXME: As NEAREST but round away from zero for a tie.  */
 138       case ROUND_UNSPECIFIED:
 139         /* Should not occur.  */
 140       case ROUND_PROCDEFINED:
 141         round_mode = ROUND_NEAREST;
 142         break;
 143       default:
 144         round_mode = dtp->u.p.current_unit->round_status;
 145         break;
 146     }
 147
 148   old_round_mode = get_fpu_rounding_mode();
 149   set_fpu_rounding_mode (round_mode);
 150
 151   switch (length)
 152     {
 153     case 4:
 154       *((GFC_REAL_4*) dest) =
 155 #if defined(HAVE_STRTOF)
 156         gfc_strtof (buffer, &endptr);
 157 #else
 158         (GFC_REAL_4) gfc_strtod (buffer, &endptr);
 159 #endif
 160       break;
 161
 162     case 8:
 163       *((GFC_REAL_8*) dest) = gfc_strtod (buffer, &endptr);
 164       break;
 165
 166 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
 167     case 10:
 168       *((GFC_REAL_10*) dest) = gfc_strtold (buffer, &endptr);
 169       break;
 170 #endif
 171
 172 #if defined(HAVE_GFC_REAL_16)
 173 # if defined(GFC_REAL_16_IS_FLOAT128)
 174     case 16:
 175       *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, &endptr);
 176       break;
 177 # elif defined(HAVE_STRTOLD)
 178     case 16:
 179       *((GFC_REAL_16*) dest) = gfc_strtold (buffer, &endptr);
 180       break;
 181 # endif
 182 #endif
 183
 184     default:
 185       internal_error (&dtp->common, "Unsupported real kind during IO");
 186     }
 187
 188   set_fpu_rounding_mode (old_round_mode);
 189
 190   if (buffer == endptr)
 191     {
 192       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 193                       "Error during floating point read");
 194       next_record (dtp, 1);
 195       return 1;
 196     }
 197
 198   return 0;
 199 }
 200
 201 /* convert_infnan()-- Convert character INF/NAN representation to the
 202    machine number.  Note: many architectures (e.g. IA-64, HP-PA) require
 203    that the storage pointed to by the dest argument is properly aligned
 204    for the type in question.  */
 205
 206 int
 207 convert_infnan (st_parameter_dt *dtp, void *dest, const char *buffer,
 208                 int length)
 209 {
 210   const char *s = buffer;
 211   int is_inf, plus = 1;
 212
 213   if (*s == '+')
 214     s++;
 215   else if (*s == '-')
 216     {
 217       s++;
 218       plus = 0;
 219     }
 220
 221   is_inf = *s == 'i';
 222
 223   switch (length)
 224     {
 225     case 4:
 226       if (is_inf)
 227         *((GFC_REAL_4*) dest) = plus ? __builtin_inff () : -__builtin_inff ();
 228       else
 229         *((GFC_REAL_4*) dest) = plus ? __builtin_nanf ("") : -__builtin_nanf ("");
 230       break;
 231
 232     case 8:
 233       if (is_inf)
 234         *((GFC_REAL_8*) dest) = plus ? __builtin_inf () : -__builtin_inf ();
 235       else
 236         *((GFC_REAL_8*) dest) = plus ? __builtin_nan ("") : -__builtin_nan ("");
 237       break;
 238
 239 #if defined(HAVE_GFC_REAL_10)
 240     case 10:
 241       if (is_inf)
 242         *((GFC_REAL_10*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
 243       else
 244         *((GFC_REAL_10*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
 245       break;
 246 #endif
 247
 248 #if defined(HAVE_GFC_REAL_16)
 249 # if defined(GFC_REAL_16_IS_FLOAT128)
 250     case 16:
 251       *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, NULL);
 252       break;
 253 # else
 254     case 16:
 255       if (is_inf)
 256         *((GFC_REAL_16*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
 257       else
 258         *((GFC_REAL_16*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
 259       break;
 260 # endif
 261 #endif
 262
 263     default:
 264       internal_error (&dtp->common, "Unsupported real kind during IO");
 265     }
 266
 267   return 0;
 268 }
 269
 270
 271 /* read_l()-- Read a logical value */
 272
 273 void
 274 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 275 {
 276   char *p;
 277   int w;
 278
 279   w = f->u.w;
 280
 281   p = read_block_form (dtp, &w);
 282
 283   if (p == NULL)
 284     return;
 285
 286   while (*p == ' ')
 287     {
 288       if (--w == 0)
 289         goto bad;
 290       p++;
 291     }
 292
 293   if (*p == '.')
 294     {
 295       if (--w == 0)
 296         goto bad;
 297       p++;
 298     }
 299
 300   switch (*p)
 301     {
 302     case 't':
 303     case 'T':
 304       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
 305       break;
 306     case 'f':
 307     case 'F':
 308       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 309       break;
 310     default:
 311     bad:
 312       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 313                       "Bad value on logical read");
 314       next_record (dtp, 1);
 315       break;
 316     }
 317 }
 318
 319
 320 static gfc_char4_t
 321 read_utf8 (st_parameter_dt *dtp, int *nbytes)
 322 {
 323   static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
 324   static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
 325   int i, nb, nread;
 326   gfc_char4_t c;
 327   char *s;
 328
 329   *nbytes = 1;
 330
 331   s = read_block_form (dtp, nbytes);
 332   if (s == NULL)
 333     return 0;
 334
 335   /* If this is a short read, just return.  */
 336   if (*nbytes == 0)
 337     return 0;
 338
 339   c = (uchar) s[0];
 340   if (c < 0x80)
 341     return c;
 342
 343   /* The number of leading 1-bits in the first byte indicates how many
 344      bytes follow.  */
 345   for (nb = 2; nb < 7; nb++)
 346     if ((c & ~masks[nb-1]) == patns[nb-1])
 347       goto found;
 348   goto invalid;
 349
 350  found:
 351   c = (c & masks[nb-1]);
 352   nread = nb - 1;
 353
 354   s = read_block_form (dtp, &nread);
 355   if (s == NULL)
 356     return 0;
 357   /* Decode the bytes read.  */
 358   for (i = 1; i < nb; i++)
 359     {
 360       gfc_char4_t n = *s++;
 361
 362       if ((n & 0xC0) != 0x80)
 363         goto invalid;
 364
 365       c = ((c << 6) + (n & 0x3F));
 366     }
 367
 368   /* Make sure the shortest possible encoding was used.  */
 369   if (c <=      0x7F && nb > 1) goto invalid;
 370   if (c <=     0x7FF && nb > 2) goto invalid;
 371   if (c <=    0xFFFF && nb > 3) goto invalid;
 372   if (c <=  0x1FFFFF && nb > 4) goto invalid;
 373   if (c <= 0x3FFFFFF && nb > 5) goto invalid;
 374
 375   /* Make sure the character is valid.  */
 376   if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
 377     goto invalid;
 378
 379   return c;
 380
 381  invalid:
 382   generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
 383   return (gfc_char4_t) '?';
 384 }
 385
 386
 387 static void
 388 read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 389 {
 390   gfc_char4_t c;
 391   char *dest;
 392   int nbytes;
 393   int i, j;
 394
 395   len = (width < len) ? len : width;
 396
 397   dest = (char *) p;
 398
 399   /* Proceed with decoding one character at a time.  */
 400   for (j = 0; j < len; j++, dest++)
 401     {
 402       c = read_utf8 (dtp, &nbytes);
 403
 404       /* Check for a short read and if so, break out.  */
 405       if (nbytes == 0)
 406         break;
 407
 408       *dest = c > 255 ? '?' : (uchar) c;
 409     }
 410
 411   /* If there was a short read, pad the remaining characters.  */
 412   for (i = j; i < len; i++)
 413     *dest++ = ' ';
 414   return;
 415 }
 416
 417 static void
 418 read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 419 {
 420   char *s;
 421   int m, n;
 422
 423   s = read_block_form (dtp, &width);
 424
 425   if (s == NULL)
 426     return;
 427   if (width > len)
 428      s += (width - len);
 429
 430   m = (width > len) ? len : width;
 431   memcpy (p, s, m);
 432
 433   n = len - width;
 434   if (n > 0)
 435     memset (p + m, ' ', n);
 436 }
 437
 438
 439 static void
 440 read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
 441 {
 442   gfc_char4_t *dest;
 443   int nbytes;
 444   int i, j;
 445
 446   len = (width < len) ? len : width;
 447
 448   dest = (gfc_char4_t *) p;
 449
 450   /* Proceed with decoding one character at a time.  */
 451   for (j = 0; j < len; j++, dest++)
 452     {
 453       *dest = read_utf8 (dtp, &nbytes);
 454
 455       /* Check for a short read and if so, break out.  */
 456       if (nbytes == 0)
 457         break;
 458     }
 459
 460   /* If there was a short read, pad the remaining characters.  */
 461   for (i = j; i < len; i++)
 462     *dest++ = (gfc_char4_t) ' ';
 463   return;
 464 }
 465
 466
 467 static void
 468 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 469 {
 470   int m, n;
 471   gfc_char4_t *dest;
 472
 473   if (is_char4_unit(dtp))
 474     {
 475       gfc_char4_t *s4;
 476
 477       s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
 478
 479       if (s4 == NULL)
 480         return;
 481       if (width > len)
 482          s4 += (width - len);
 483
 484       m = ((int) width > len) ? len : (int) width;
 485
 486       dest = (gfc_char4_t *) p;
 487
 488       for (n = 0; n < m; n++)
 489         *dest++ = *s4++;
 490
 491       for (n = 0; n < len - (int) width; n++)
 492         *dest++ = (gfc_char4_t) ' ';
 493     }
 494   else
 495     {
 496       char *s;
 497
 498       s = read_block_form (dtp, &width);
 499
 500       if (s == NULL)
 501         return;
 502       if (width > len)
 503          s += (width - len);
 504
 505       m = ((int) width > len) ? len : (int) width;
 506
 507       dest = (gfc_char4_t *) p;
 508
 509       for (n = 0; n < m; n++, dest++, s++)
 510         *dest = (unsigned char ) *s;
 511
 512       for (n = 0; n < len - (int) width; n++, dest++)
 513         *dest = (unsigned char) ' ';
 514     }
 515 }
 516
 517
 518 /* read_a()-- Read a character record into a KIND=1 character destination,
 519    processing UTF-8 encoding if necessary.  */
 520
 521 void
 522 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 523 {
 524   int wi;
 525   int w;
 526
 527   wi = f->u.w;
 528   if (wi == -1) /* '(A)' edit descriptor  */
 529     wi = length;
 530   w = wi;
 531
 532   /* Read in w characters, treating comma as not a separator.  */
 533   dtp->u.p.sf_read_comma = 0;
 534
 535   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 536     read_utf8_char1 (dtp, p, length, w);
 537   else
 538     read_default_char1 (dtp, p, length, w);
 539
 540   dtp->u.p.sf_read_comma =
 541     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 542 }
 543
 544
 545 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
 546    processing UTF-8 encoding if necessary.  */
 547
 548 void
 549 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 550 {
 551   int w;
 552
 553   w = f->u.w;
 554   if (w == -1) /* '(A)' edit descriptor  */
 555     w = length;
 556
 557   /* Read in w characters, treating comma as not a separator.  */
 558   dtp->u.p.sf_read_comma = 0;
 559
 560   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 561     read_utf8_char4 (dtp, p, length, w);
 562   else
 563     read_default_char4 (dtp, p, length, w);
 564
 565   dtp->u.p.sf_read_comma =
 566     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 567 }
 568
 569 /* eat_leading_spaces()-- Given a character pointer and a width,
 570  * ignore the leading spaces.  */
 571
 572 static char *
 573 eat_leading_spaces (int *width, char *p)
 574 {
 575   for (;;)
 576     {
 577       if (*width == 0 || *p != ' ')
 578         break;
 579
 580       (*width)--;
 581       p++;
 582     }
 583
 584   return p;
 585 }
 586
 587
 588 static char
 589 next_char (st_parameter_dt *dtp, char **p, int *w)
 590 {
 591   char c, *q;
 592
 593   if (*w == 0)
 594     return '\0';
 595
 596   q = *p;
 597   c = *q++;
 598   *p = q;
 599
 600   (*w)--;
 601
 602   if (c != ' ')
 603     return c;
 604   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
 605     return ' ';  /* return a blank to signal a null */
 606
 607   /* At this point, the rest of the field has to be trailing blanks */
 608
 609   while (*w > 0)
 610     {
 611       if (*q++ != ' ')
 612         return '?';
 613       (*w)--;
 614     }
 615
 616   *p = q;
 617   return '\0';
 618 }
 619
 620
 621 /* read_decimal()-- Read a decimal integer value.  The values here are
 622  * signed values. */
 623
 624 void
 625 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 626 {
 627   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 628   GFC_INTEGER_LARGEST v;
 629   int w, negative;
 630   char c, *p;
 631
 632   w = f->u.w;
 633
 634   p = read_block_form (dtp, &w);
 635
 636   if (p == NULL)
 637     return;
 638
 639   p = eat_leading_spaces (&w, p);
 640   if (w == 0)
 641     {
 642       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 643       return;
 644     }
 645
 646   negative = 0;
 647
 648   switch (*p)
 649     {
 650     case '-':
 651       negative = 1;
 652       /* Fall through */
 653
 654     case '+':
 655       p++;
 656       if (--w == 0)
 657         goto bad;
 658       /* Fall through */
 659
 660     default:
 661       break;
 662     }
 663
 664   maxv = si_max (length);
 665   if (negative)
 666     maxv++;
 667   maxv_10 = maxv / 10;
 668
 669   /* At this point we have a digit-string */
 670   value = 0;
 671
 672   for (;;)
 673     {
 674       c = next_char (dtp, &p, &w);
 675       if (c == '\0')
 676         break;
 677
 678       if (c == ' ')
 679         {
 680           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 681           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 682         }
 683
 684       if (c < '0' || c > '9')
 685         goto bad;
 686
 687       if (value > maxv_10)
 688         goto overflow;
 689
 690       c -= '0';
 691       value = 10 * value;
 692
 693       if (value > maxv - c)
 694         goto overflow;
 695       value += c;
 696     }
 697
 698   if (negative)
 699     v = -value;
 700   else
 701     v = value;
 702
 703   set_integer (dest, v, length);
 704   return;
 705
 706  bad:
 707   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 708                   "Bad value during integer read");
 709   next_record (dtp, 1);
 710   return;
 711
 712  overflow:
 713   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 714                   "Value overflowed during integer read");
 715   next_record (dtp, 1);
 716
 717 }
 718
 719
 720 /* read_radix()-- This function reads values for non-decimal radixes.
 721  * The difference here is that we treat the values here as unsigned
 722  * values for the purposes of overflow.  If minus sign is present and
 723  * the top bit is set, the value will be incorrect. */
 724
 725 void
 726 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 727             int radix)
 728 {
 729   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 730   GFC_INTEGER_LARGEST v;
 731   int w, negative;
 732   char c, *p;
 733
 734   w = f->u.w;
 735
 736   p = read_block_form (dtp, &w);
 737
 738   if (p == NULL)
 739     return;
 740
 741   p = eat_leading_spaces (&w, p);
 742   if (w == 0)
 743     {
 744       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 745       return;
 746     }
 747
 748   /* Maximum unsigned value, assuming two's complement.  */
 749   maxv = 2 * si_max (length) + 1;
 750   maxv_r = maxv / radix;
 751
 752   negative = 0;
 753   value = 0;
 754
 755   switch (*p)
 756     {
 757     case '-':
 758       negative = 1;
 759       /* Fall through */
 760
 761     case '+':
 762       p++;
 763       if (--w == 0)
 764         goto bad;
 765       /* Fall through */
 766
 767     default:
 768       break;
 769     }
 770
 771   /* At this point we have a digit-string */
 772   value = 0;
 773
 774   for (;;)
 775     {
 776       c = next_char (dtp, &p, &w);
 777       if (c == '\0')
 778         break;
 779       if (c == ' ')
 780         {
 781           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 782           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 783         }
 784
 785       switch (radix)
 786         {
 787         case 2:
 788           if (c < '0' || c > '1')
 789             goto bad;
 790           break;
 791
 792         case 8:
 793           if (c < '0' || c > '7')
 794             goto bad;
 795           break;
 796
 797         case 16:
 798           switch (c)
 799             {
 800             case '0':
 801             case '1':
 802             case '2':
 803             case '3':
 804             case '4':
 805             case '5':
 806             case '6':
 807             case '7':
 808             case '8':
 809             case '9':
 810               break;
 811
 812             case 'a':
 813             case 'b':
 814             case 'c':
 815             case 'd':
 816             case 'e':
 817             case 'f':
 818               c = c - 'a' + '9' + 1;
 819               break;
 820
 821             case 'A':
 822             case 'B':
 823             case 'C':
 824             case 'D':
 825             case 'E':
 826             case 'F':
 827               c = c - 'A' + '9' + 1;
 828               break;
 829
 830             default:
 831               goto bad;
 832             }
 833
 834           break;
 835         }
 836
 837       if (value > maxv_r)
 838         goto overflow;
 839
 840       c -= '0';
 841       value = radix * value;
 842
 843       if (maxv - c < value)
 844         goto overflow;
 845       value += c;
 846     }
 847
 848   v = value;
 849   if (negative)
 850     v = -v;
 851
 852   set_integer (dest, v, length);
 853   return;
 854
 855  bad:
 856   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 857                   "Bad value during integer read");
 858   next_record (dtp, 1);
 859   return;
 860
 861  overflow:
 862   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 863                   "Value overflowed during integer read");
 864   next_record (dtp, 1);
 865
 866 }
 867
 868
 869 /* read_f()-- Read a floating point number with F-style editing, which
 870    is what all of the other floating point descriptors behave as.  The
 871    tricky part is that optional spaces are allowed after an E or D,
 872    and the implicit decimal point if a decimal point is not present in
 873    the input.  */
 874
 875 void
 876 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 877 {
 878   int w, seen_dp, exponent;
 879   int exponent_sign;
 880   const char *p;
 881   char *buffer;
 882   char *out;
 883   int seen_int_digit; /* Seen a digit before the decimal point?  */
 884   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 885
 886   seen_dp = 0;
 887   seen_int_digit = 0;
 888   seen_dec_digit = 0;
 889   exponent_sign = 1;
 890   exponent = 0;
 891   w = f->u.w;
 892
 893   /* Read in the next block.  */
 894   p = read_block_form (dtp, &w);
 895   if (p == NULL)
 896     return;
 897   p = eat_leading_spaces (&w, (char*) p);
 898   if (w == 0)
 899     goto zero;
 900
 901   /* In this buffer we're going to re-format the number cleanly to be parsed
 902      by convert_real in the end; this assures we're using strtod from the
 903      C library for parsing and thus probably get the best accuracy possible.
 904      This process may add a '+0.0' in front of the number as well as change the
 905      exponent because of an implicit decimal point or the like.  Thus allocating
 906      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 907      original buffer had should be enough.  */
 908   buffer = gfc_alloca (w + 11);
 909   out = buffer;
 910
 911   /* Optional sign */
 912   if (*p == '-' || *p == '+')
 913     {
 914       if (*p == '-')
 915         *(out++) = '-';
 916       ++p;
 917       --w;
 918     }
 919
 920   p = eat_leading_spaces (&w, (char*) p);
 921   if (w == 0)
 922     goto zero;
 923
 924   /* Check for Infinity or NaN.  */
 925   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 926     {
 927       int seen_paren = 0;
 928       char *save = out;
 929
 930       /* Scan through the buffer keeping track of spaces and parenthesis. We
 931          null terminate the string as soon as we see a left paren or if we are
 932          BLANK_NULL mode.  Leading spaces have already been skipped above,
 933          trailing spaces are ignored by converting to '\0'. A space
 934          between "NaN" and the optional perenthesis is not permitted.  */
 935       while (w > 0)
 936         {
 937           *out = tolower (*p);
 938           switch (*p)
 939             {
 940             case ' ':
 941               if (dtp->u.p.blank_status == BLANK_ZERO)
 942                 {
 943                   *out = '0';
 944                   break;
 945                 }
 946               *out = '\0';
 947               if (seen_paren == 1)
 948                 goto bad_float;
 949               break;
 950             case '(':
 951               seen_paren++;
 952               *out = '\0';
 953               break;
 954             case ')':
 955               if (seen_paren++ != 1)
 956                 goto bad_float;
 957               break;
 958             default:
 959               if (!isalnum (*out))
 960                 goto bad_float;
 961             }
 962           --w;
 963           ++p;
 964           ++out;
 965         }
 966
 967       *out = '\0';
 968
 969       if (seen_paren != 0 && seen_paren != 2)
 970         goto bad_float;
 971
 972       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 973         {
 974            if (seen_paren)
 975              goto bad_float;
 976         }
 977       else if (strcmp (save, "nan") != 0)
 978         goto bad_float;
 979
 980       convert_infnan (dtp, dest, buffer, length);
 981       return;
 982     }
 983
 984   /* Process the mantissa string.  */
 985   while (w > 0)
 986     {
 987       switch (*p)
 988         {
 989         case ',':
 990           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 991             goto bad_float;
 992           /* Fall through.  */
 993         case '.':
 994           if (seen_dp)
 995             goto bad_float;
 996           if (!seen_int_digit)
 997             *(out++) = '0';
 998           *(out++) = '.';
 999           seen_dp = 1;
1000           break;
1001
1002         case ' ':
1003           if (dtp->u.p.blank_status == BLANK_ZERO)
1004             {
1005               *(out++) = '0';
1006               goto found_digit;
1007             }
1008           else if (dtp->u.p.blank_status == BLANK_NULL)
1009             break;
1010           else
1011             /* TODO: Should we check instead that there are only trailing
1012                blanks here, as is done below for exponents?  */
1013             goto done;
1014           /* Fall through.  */
1015         case '0':
1016         case '1':
1017         case '2':
1018         case '3':
1019         case '4':
1020         case '5':
1021         case '6':
1022         case '7':
1023         case '8':
1024         case '9':
1025           *(out++) = *p;
1026 found_digit:
1027           if (!seen_dp)
1028             seen_int_digit = 1;
1029           else
1030             seen_dec_digit = 1;
1031           break;
1032
1033         case '-':
1034         case '+':
1035           goto exponent;
1036
1037         case 'e':
1038         case 'E':
1039         case 'd':
1040         case 'D':
1041         case 'q':
1042         case 'Q':
1043           ++p;
1044           --w;
1045           goto exponent;
1046
1047         default:
1048           goto bad_float;
1049         }
1050
1051       ++p;
1052       --w;
1053     }
1054
1055   /* No exponent has been seen, so we use the current scale factor.  */
1056   exponent = - dtp->u.p.scale_factor;
1057   goto done;
1058
1059   /* At this point the start of an exponent has been found.  */
1060 exponent:
1061   p = eat_leading_spaces (&w, (char*) p);
1062   if (*p == '-' || *p == '+')
1063     {
1064       if (*p == '-')
1065         exponent_sign = -1;
1066       ++p;
1067       --w;
1068     }
1069
1070   /* At this point a digit string is required.  We calculate the value
1071      of the exponent in order to take account of the scale factor and
1072      the d parameter before explict conversion takes place.  */
1073
1074   if (w == 0)
1075     goto bad_float;
1076
1077   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1078     {
1079       while (w > 0 && isdigit (*p))
1080         {
1081           exponent *= 10;
1082           exponent += *p - '0';
1083           ++p;
1084           --w;
1085         }
1086
1087       /* Only allow trailing blanks.  */
1088       while (w > 0)
1089         {
1090           if (*p != ' ')
1091             goto bad_float;
1092           ++p;
1093           --w;
1094         }
1095     }
1096   else  /* BZ or BN status is enabled.  */
1097     {
1098       while (w > 0)
1099         {
1100           if (*p == ' ')
1101             {
1102               if (dtp->u.p.blank_status == BLANK_ZERO)
1103                 exponent *= 10;
1104               else
1105                 assert (dtp->u.p.blank_status == BLANK_NULL);
1106             }
1107           else if (!isdigit (*p))
1108             goto bad_float;
1109           else
1110             {
1111               exponent *= 10;
1112               exponent += *p - '0';
1113             }
1114
1115           ++p;
1116           --w;
1117         }
1118     }
1119
1120   exponent *= exponent_sign;
1121
1122 done:
1123   /* Use the precision specified in the format if no decimal point has been
1124      seen.  */
1125   if (!seen_dp)
1126     exponent -= f->u.real.d;
1127
1128   /* Output a trailing '0' after decimal point if not yet found.  */
1129   if (seen_dp && !seen_dec_digit)
1130     *(out++) = '0';
1131   /* Handle input of style "E+NN" by inserting a 0 for the
1132      significand.  */
1133   else if (!seen_int_digit && !seen_dec_digit)
1134     {
1135       notify_std (&dtp->common, GFC_STD_LEGACY,
1136                   "REAL input of style 'E+NN'");
1137       *(out++) = '0';
1138     }
1139
1140   /* Print out the exponent to finish the reformatted number.  Maximum 4
1141      digits for the exponent.  */
1142   if (exponent != 0)
1143     {
1144       int dig;
1145
1146       *(out++) = 'e';
1147       if (exponent < 0)
1148         {
1149           *(out++) = '-';
1150           exponent = - exponent;
1151         }
1152
1153       if (exponent >= 10000)
1154         goto bad_float;
1155
1156       for (dig = 3; dig >= 0; --dig)
1157         {
1158           out[dig] = (char) ('0' + exponent % 10);
1159           exponent /= 10;
1160         }
1161       out += 4;
1162     }
1163   *(out++) = '\0';
1164
1165   /* Do the actual conversion.  */
1166   convert_real (dtp, dest, buffer, length);
1167
1168   return;
1169
1170   /* The value read is zero.  */
1171 zero:
1172   switch (length)
1173     {
1174       case 4:
1175         *((GFC_REAL_4 *) dest) = 0.0;
1176         break;
1177
1178       case 8:
1179         *((GFC_REAL_8 *) dest) = 0.0;
1180         break;
1181
1182 #ifdef HAVE_GFC_REAL_10
1183       case 10:
1184         *((GFC_REAL_10 *) dest) = 0.0;
1185         break;
1186 #endif
1187
1188 #ifdef HAVE_GFC_REAL_16
1189       case 16:
1190         *((GFC_REAL_16 *) dest) = 0.0;
1191         break;
1192 #endif
1193
1194       default:
1195         internal_error (&dtp->common, "Unsupported real kind during IO");
1196     }
1197   return;
1198
1199 bad_float:
1200   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1201                   "Bad value during floating point read");
1202   next_record (dtp, 1);
1203   return;
1204 }
1205
1206
1207 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1208  * and never look at it. */
1209
1210 void
1211 read_x (st_parameter_dt *dtp, int n)
1212 {
1213   int length, q, q2;
1214
1215   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1216        && dtp->u.p.current_unit->bytes_left < n)
1217     n = dtp->u.p.current_unit->bytes_left;
1218
1219   if (n == 0)
1220     return;
1221
1222   length = n;
1223
1224   if (is_internal_unit (dtp))
1225     {
1226       mem_alloc_r (dtp->u.p.current_unit->s, &length);
1227       if (unlikely (length < n))
1228         n = length;
1229       goto done;
1230     }
1231
1232   if (dtp->u.p.sf_seen_eor)
1233     return;
1234
1235   n = 0;
1236   while (n < length)
1237     {
1238       q = fbuf_getc (dtp->u.p.current_unit);
1239       if (q == EOF)
1240         break;
1241       else if (q == '\n' || q == '\r')
1242         {
1243           /* Unexpected end of line. Set the position.  */
1244           dtp->u.p.sf_seen_eor = 1;
1245
1246           /* If we see an EOR during non-advancing I/O, we need to skip
1247              the rest of the I/O statement.  Set the corresponding flag.  */
1248           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1249             dtp->u.p.eor_condition = 1;
1250
1251           /* If we encounter a CR, it might be a CRLF.  */
1252           if (q == '\r') /* Probably a CRLF */
1253             {
1254               /* See if there is an LF.  */
1255               q2 = fbuf_getc (dtp->u.p.current_unit);
1256               if (q2 == '\n')
1257                 dtp->u.p.sf_seen_eor = 2;
1258               else if (q2 != EOF) /* Oops, seek back.  */
1259                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1260             }
1261           goto done;
1262         }
1263       n++;
1264     }
1265
1266  done:
1267   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1268     dtp->u.p.size_used += (GFC_IO_INT) n;
1269   dtp->u.p.current_unit->bytes_left -= n;
1270   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1271 }
1272