main/libgfortran/io/read.c

   1 /* Copyright (C) 2002-2014 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)
 681             {
 682               /* Skip spaces.  */
 683               for ( ; w > 0; p++, w--)
 684                 if (*p != ' ') break;
 685               continue;
 686             }
 687           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 688         }
 689
 690       if (c < '0' || c > '9')
 691         goto bad;
 692
 693       if (value > maxv_10)
 694         goto overflow;
 695
 696       c -= '0';
 697       value = 10 * value;
 698
 699       if (value > maxv - c)
 700         goto overflow;
 701       value += c;
 702     }
 703
 704   if (negative)
 705     v = -value;
 706   else
 707     v = value;
 708
 709   set_integer (dest, v, length);
 710   return;
 711
 712  bad:
 713   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 714                   "Bad value during integer read");
 715   next_record (dtp, 1);
 716   return;
 717
 718  overflow:
 719   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 720                   "Value overflowed during integer read");
 721   next_record (dtp, 1);
 722
 723 }
 724
 725
 726 /* read_radix()-- This function reads values for non-decimal radixes.
 727  * The difference here is that we treat the values here as unsigned
 728  * values for the purposes of overflow.  If minus sign is present and
 729  * the top bit is set, the value will be incorrect. */
 730
 731 void
 732 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 733             int radix)
 734 {
 735   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 736   GFC_INTEGER_LARGEST v;
 737   int w, negative;
 738   char c, *p;
 739
 740   w = f->u.w;
 741
 742   p = read_block_form (dtp, &w);
 743
 744   if (p == NULL)
 745     return;
 746
 747   p = eat_leading_spaces (&w, p);
 748   if (w == 0)
 749     {
 750       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 751       return;
 752     }
 753
 754   /* Maximum unsigned value, assuming two's complement.  */
 755   maxv = 2 * si_max (length) + 1;
 756   maxv_r = maxv / radix;
 757
 758   negative = 0;
 759   value = 0;
 760
 761   switch (*p)
 762     {
 763     case '-':
 764       negative = 1;
 765       /* Fall through */
 766
 767     case '+':
 768       p++;
 769       if (--w == 0)
 770         goto bad;
 771       /* Fall through */
 772
 773     default:
 774       break;
 775     }
 776
 777   /* At this point we have a digit-string */
 778   value = 0;
 779
 780   for (;;)
 781     {
 782       c = next_char (dtp, &p, &w);
 783       if (c == '\0')
 784         break;
 785       if (c == ' ')
 786         {
 787           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 788           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 789         }
 790
 791       switch (radix)
 792         {
 793         case 2:
 794           if (c < '0' || c > '1')
 795             goto bad;
 796           break;
 797
 798         case 8:
 799           if (c < '0' || c > '7')
 800             goto bad;
 801           break;
 802
 803         case 16:
 804           switch (c)
 805             {
 806             case '0':
 807             case '1':
 808             case '2':
 809             case '3':
 810             case '4':
 811             case '5':
 812             case '6':
 813             case '7':
 814             case '8':
 815             case '9':
 816               break;
 817
 818             case 'a':
 819             case 'b':
 820             case 'c':
 821             case 'd':
 822             case 'e':
 823             case 'f':
 824               c = c - 'a' + '9' + 1;
 825               break;
 826
 827             case 'A':
 828             case 'B':
 829             case 'C':
 830             case 'D':
 831             case 'E':
 832             case 'F':
 833               c = c - 'A' + '9' + 1;
 834               break;
 835
 836             default:
 837               goto bad;
 838             }
 839
 840           break;
 841         }
 842
 843       if (value > maxv_r)
 844         goto overflow;
 845
 846       c -= '0';
 847       value = radix * value;
 848
 849       if (maxv - c < value)
 850         goto overflow;
 851       value += c;
 852     }
 853
 854   v = value;
 855   if (negative)
 856     v = -v;
 857
 858   set_integer (dest, v, length);
 859   return;
 860
 861  bad:
 862   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 863                   "Bad value during integer read");
 864   next_record (dtp, 1);
 865   return;
 866
 867  overflow:
 868   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 869                   "Value overflowed during integer read");
 870   next_record (dtp, 1);
 871
 872 }
 873
 874
 875 /* read_f()-- Read a floating point number with F-style editing, which
 876    is what all of the other floating point descriptors behave as.  The
 877    tricky part is that optional spaces are allowed after an E or D,
 878    and the implicit decimal point if a decimal point is not present in
 879    the input.  */
 880
 881 void
 882 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 883 {
 884   int w, seen_dp, exponent;
 885   int exponent_sign;
 886   const char *p;
 887   char *buffer;
 888   char *out;
 889   int seen_int_digit; /* Seen a digit before the decimal point?  */
 890   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 891
 892   seen_dp = 0;
 893   seen_int_digit = 0;
 894   seen_dec_digit = 0;
 895   exponent_sign = 1;
 896   exponent = 0;
 897   w = f->u.w;
 898
 899   /* Read in the next block.  */
 900   p = read_block_form (dtp, &w);
 901   if (p == NULL)
 902     return;
 903   p = eat_leading_spaces (&w, (char*) p);
 904   if (w == 0)
 905     goto zero;
 906
 907   /* In this buffer we're going to re-format the number cleanly to be parsed
 908      by convert_real in the end; this assures we're using strtod from the
 909      C library for parsing and thus probably get the best accuracy possible.
 910      This process may add a '+0.0' in front of the number as well as change the
 911      exponent because of an implicit decimal point or the like.  Thus allocating
 912      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 913      original buffer had should be enough.  */
 914   buffer = gfc_alloca (w + 11);
 915   out = buffer;
 916
 917   /* Optional sign */
 918   if (*p == '-' || *p == '+')
 919     {
 920       if (*p == '-')
 921         *(out++) = '-';
 922       ++p;
 923       --w;
 924     }
 925
 926   p = eat_leading_spaces (&w, (char*) p);
 927   if (w == 0)
 928     goto zero;
 929
 930   /* Check for Infinity or NaN.  */
 931   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 932     {
 933       int seen_paren = 0;
 934       char *save = out;
 935
 936       /* Scan through the buffer keeping track of spaces and parenthesis. We
 937          null terminate the string as soon as we see a left paren or if we are
 938          BLANK_NULL mode.  Leading spaces have already been skipped above,
 939          trailing spaces are ignored by converting to '\0'. A space
 940          between "NaN" and the optional perenthesis is not permitted.  */
 941       while (w > 0)
 942         {
 943           *out = tolower (*p);
 944           switch (*p)
 945             {
 946             case ' ':
 947               if (dtp->u.p.blank_status == BLANK_ZERO)
 948                 {
 949                   *out = '0';
 950                   break;
 951                 }
 952               *out = '\0';
 953               if (seen_paren == 1)
 954                 goto bad_float;
 955               break;
 956             case '(':
 957               seen_paren++;
 958               *out = '\0';
 959               break;
 960             case ')':
 961               if (seen_paren++ != 1)
 962                 goto bad_float;
 963               break;
 964             default:
 965               if (!isalnum (*out))
 966                 goto bad_float;
 967             }
 968           --w;
 969           ++p;
 970           ++out;
 971         }
 972
 973       *out = '\0';
 974
 975       if (seen_paren != 0 && seen_paren != 2)
 976         goto bad_float;
 977
 978       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 979         {
 980            if (seen_paren)
 981              goto bad_float;
 982         }
 983       else if (strcmp (save, "nan") != 0)
 984         goto bad_float;
 985
 986       convert_infnan (dtp, dest, buffer, length);
 987       return;
 988     }
 989
 990   /* Process the mantissa string.  */
 991   while (w > 0)
 992     {
 993       switch (*p)
 994         {
 995         case ',':
 996           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 997             goto bad_float;
 998           /* Fall through.  */
 999         case '.':
1000           if (seen_dp)
1001             goto bad_float;
1002           if (!seen_int_digit)
1003             *(out++) = '0';
1004           *(out++) = '.';
1005           seen_dp = 1;
1006           break;
1007
1008         case ' ':
1009           if (dtp->u.p.blank_status == BLANK_ZERO)
1010             {
1011               *(out++) = '0';
1012               goto found_digit;
1013             }
1014           else if (dtp->u.p.blank_status == BLANK_NULL)
1015             break;
1016           else
1017             /* TODO: Should we check instead that there are only trailing
1018                blanks here, as is done below for exponents?  */
1019             goto done;
1020           /* Fall through.  */
1021         case '0':
1022         case '1':
1023         case '2':
1024         case '3':
1025         case '4':
1026         case '5':
1027         case '6':
1028         case '7':
1029         case '8':
1030         case '9':
1031           *(out++) = *p;
1032 found_digit:
1033           if (!seen_dp)
1034             seen_int_digit = 1;
1035           else
1036             seen_dec_digit = 1;
1037           break;
1038
1039         case '-':
1040         case '+':
1041           goto exponent;
1042
1043         case 'e':
1044         case 'E':
1045         case 'd':
1046         case 'D':
1047         case 'q':
1048         case 'Q':
1049           ++p;
1050           --w;
1051           goto exponent;
1052
1053         default:
1054           goto bad_float;
1055         }
1056
1057       ++p;
1058       --w;
1059     }
1060
1061   /* No exponent has been seen, so we use the current scale factor.  */
1062   exponent = - dtp->u.p.scale_factor;
1063   goto done;
1064
1065   /* At this point the start of an exponent has been found.  */
1066 exponent:
1067   p = eat_leading_spaces (&w, (char*) p);
1068   if (*p == '-' || *p == '+')
1069     {
1070       if (*p == '-')
1071         exponent_sign = -1;
1072       ++p;
1073       --w;
1074     }
1075
1076   /* At this point a digit string is required.  We calculate the value
1077      of the exponent in order to take account of the scale factor and
1078      the d parameter before explict conversion takes place.  */
1079
1080   if (w == 0)
1081     goto bad_float;
1082
1083   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1084     {
1085       while (w > 0 && isdigit (*p))
1086         {
1087           exponent *= 10;
1088           exponent += *p - '0';
1089           ++p;
1090           --w;
1091         }
1092
1093       /* Only allow trailing blanks.  */
1094       while (w > 0)
1095         {
1096           if (*p != ' ')
1097             goto bad_float;
1098           ++p;
1099           --w;
1100         }
1101     }
1102   else  /* BZ or BN status is enabled.  */
1103     {
1104       while (w > 0)
1105         {
1106           if (*p == ' ')
1107             {
1108               if (dtp->u.p.blank_status == BLANK_ZERO)
1109                 exponent *= 10;
1110               else
1111                 assert (dtp->u.p.blank_status == BLANK_NULL);
1112             }
1113           else if (!isdigit (*p))
1114             goto bad_float;
1115           else
1116             {
1117               exponent *= 10;
1118               exponent += *p - '0';
1119             }
1120
1121           ++p;
1122           --w;
1123         }
1124     }
1125
1126   exponent *= exponent_sign;
1127
1128 done:
1129   /* Use the precision specified in the format if no decimal point has been
1130      seen.  */
1131   if (!seen_dp)
1132     exponent -= f->u.real.d;
1133
1134   /* Output a trailing '0' after decimal point if not yet found.  */
1135   if (seen_dp && !seen_dec_digit)
1136     *(out++) = '0';
1137   /* Handle input of style "E+NN" by inserting a 0 for the
1138      significand.  */
1139   else if (!seen_int_digit && !seen_dec_digit)
1140     {
1141       notify_std (&dtp->common, GFC_STD_LEGACY,
1142                   "REAL input of style 'E+NN'");
1143       *(out++) = '0';
1144     }
1145
1146   /* Print out the exponent to finish the reformatted number.  Maximum 4
1147      digits for the exponent.  */
1148   if (exponent != 0)
1149     {
1150       int dig;
1151
1152       *(out++) = 'e';
1153       if (exponent < 0)
1154         {
1155           *(out++) = '-';
1156           exponent = - exponent;
1157         }
1158
1159       if (exponent >= 10000)
1160         goto bad_float;
1161
1162       for (dig = 3; dig >= 0; --dig)
1163         {
1164           out[dig] = (char) ('0' + exponent % 10);
1165           exponent /= 10;
1166         }
1167       out += 4;
1168     }
1169   *(out++) = '\0';
1170
1171   /* Do the actual conversion.  */
1172   convert_real (dtp, dest, buffer, length);
1173
1174   return;
1175
1176   /* The value read is zero.  */
1177 zero:
1178   switch (length)
1179     {
1180       case 4:
1181         *((GFC_REAL_4 *) dest) = 0.0;
1182         break;
1183
1184       case 8:
1185         *((GFC_REAL_8 *) dest) = 0.0;
1186         break;
1187
1188 #ifdef HAVE_GFC_REAL_10
1189       case 10:
1190         *((GFC_REAL_10 *) dest) = 0.0;
1191         break;
1192 #endif
1193
1194 #ifdef HAVE_GFC_REAL_16
1195       case 16:
1196         *((GFC_REAL_16 *) dest) = 0.0;
1197         break;
1198 #endif
1199
1200       default:
1201         internal_error (&dtp->common, "Unsupported real kind during IO");
1202     }
1203   return;
1204
1205 bad_float:
1206   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1207                   "Bad value during floating point read");
1208   next_record (dtp, 1);
1209   return;
1210 }
1211
1212
1213 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1214  * and never look at it. */
1215
1216 void
1217 read_x (st_parameter_dt *dtp, int n)
1218 {
1219   int length, q, q2;
1220
1221   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1222        && dtp->u.p.current_unit->bytes_left < n)
1223     n = dtp->u.p.current_unit->bytes_left;
1224
1225   if (n == 0)
1226     return;
1227
1228   length = n;
1229
1230   if (is_internal_unit (dtp))
1231     {
1232       mem_alloc_r (dtp->u.p.current_unit->s, &length);
1233       if (unlikely (length < n))
1234         n = length;
1235       goto done;
1236     }
1237
1238   if (dtp->u.p.sf_seen_eor)
1239     return;
1240
1241   n = 0;
1242   while (n < length)
1243     {
1244       q = fbuf_getc (dtp->u.p.current_unit);
1245       if (q == EOF)
1246         break;
1247       else if (q == '\n' || q == '\r')
1248         {
1249           /* Unexpected end of line. Set the position.  */
1250           dtp->u.p.sf_seen_eor = 1;
1251
1252           /* If we see an EOR during non-advancing I/O, we need to skip
1253              the rest of the I/O statement.  Set the corresponding flag.  */
1254           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1255             dtp->u.p.eor_condition = 1;
1256
1257           /* If we encounter a CR, it might be a CRLF.  */
1258           if (q == '\r') /* Probably a CRLF */
1259             {
1260               /* See if there is an LF.  */
1261               q2 = fbuf_getc (dtp->u.p.current_unit);
1262               if (q2 == '\n')
1263                 dtp->u.p.sf_seen_eor = 2;
1264               else if (q2 != EOF) /* Oops, seek back.  */
1265                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1266             }
1267           goto done;
1268         }
1269       n++;
1270     }
1271
1272  done:
1273   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1274     dtp->u.p.size_used += (GFC_IO_INT) n;
1275   dtp->u.p.current_unit->bytes_left -= n;
1276   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1277 }
1278