l4/pkg/libgfortran/lib/contrib/io/read.c

   1 /* Copyright (C) 2002-2015 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 #define READF_TMP 50
 885   char tmp[READF_TMP];
 886   size_t buf_size = 0;
 887   int w, seen_dp, exponent;
 888   int exponent_sign;
 889   const char *p;
 890   char *buffer;
 891   char *out;
 892   int seen_int_digit; /* Seen a digit before the decimal point?  */
 893   int seen_dec_digit; /* Seen a digit after the decimal point?  */
 894
 895   seen_dp = 0;
 896   seen_int_digit = 0;
 897   seen_dec_digit = 0;
 898   exponent_sign = 1;
 899   exponent = 0;
 900   w = f->u.w;
 901   buffer = tmp;
 902
 903   /* Read in the next block.  */
 904   p = read_block_form (dtp, &w);
 905   if (p == NULL)
 906     return;
 907   p = eat_leading_spaces (&w, (char*) p);
 908   if (w == 0)
 909     goto zero;
 910
 911   /* In this buffer we're going to re-format the number cleanly to be parsed
 912      by convert_real in the end; this assures we're using strtod from the
 913      C library for parsing and thus probably get the best accuracy possible.
 914      This process may add a '+0.0' in front of the number as well as change the
 915      exponent because of an implicit decimal point or the like.  Thus allocating
 916      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
 917      original buffer had should be enough.  */
 918   buf_size = w + 11;
 919   if (buf_size > READF_TMP)
 920     buffer = xmalloc (buf_size);
 921
 922   out = buffer;
 923
 924   /* Optional sign */
 925   if (*p == '-' || *p == '+')
 926     {
 927       if (*p == '-')
 928         *(out++) = '-';
 929       ++p;
 930       --w;
 931     }
 932
 933   p = eat_leading_spaces (&w, (char*) p);
 934   if (w == 0)
 935     goto zero;
 936
 937   /* Check for Infinity or NaN.  */
 938   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
 939     {
 940       int seen_paren = 0;
 941       char *save = out;
 942
 943       /* Scan through the buffer keeping track of spaces and parenthesis. We
 944          null terminate the string as soon as we see a left paren or if we are
 945          BLANK_NULL mode.  Leading spaces have already been skipped above,
 946          trailing spaces are ignored by converting to '\0'. A space
 947          between "NaN" and the optional perenthesis is not permitted.  */
 948       while (w > 0)
 949         {
 950           *out = tolower (*p);
 951           switch (*p)
 952             {
 953             case ' ':
 954               if (dtp->u.p.blank_status == BLANK_ZERO)
 955                 {
 956                   *out = '0';
 957                   break;
 958                 }
 959               *out = '\0';
 960               if (seen_paren == 1)
 961                 goto bad_float;
 962               break;
 963             case '(':
 964               seen_paren++;
 965               *out = '\0';
 966               break;
 967             case ')':
 968               if (seen_paren++ != 1)
 969                 goto bad_float;
 970               break;
 971             default:
 972               if (!isalnum (*out))
 973                 goto bad_float;
 974             }
 975           --w;
 976           ++p;
 977           ++out;
 978         }
 979
 980       *out = '\0';
 981
 982       if (seen_paren != 0 && seen_paren != 2)
 983         goto bad_float;
 984
 985       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
 986         {
 987            if (seen_paren)
 988              goto bad_float;
 989         }
 990       else if (strcmp (save, "nan") != 0)
 991         goto bad_float;
 992
 993       convert_infnan (dtp, dest, buffer, length);
 994       if (buf_size > READF_TMP)
 995         free (buffer);
 996       return;
 997     }
 998
 999   /* Process the mantissa string.  */
1000   while (w > 0)
1001     {
1002       switch (*p)
1003         {
1004         case ',':
1005           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
1006             goto bad_float;
1007           /* Fall through.  */
1008         case '.':
1009           if (seen_dp)
1010             goto bad_float;
1011           if (!seen_int_digit)
1012             *(out++) = '0';
1013           *(out++) = '.';
1014           seen_dp = 1;
1015           break;
1016
1017         case ' ':
1018           if (dtp->u.p.blank_status == BLANK_ZERO)
1019             {
1020               *(out++) = '0';
1021               goto found_digit;
1022             }
1023           else if (dtp->u.p.blank_status == BLANK_NULL)
1024             break;
1025           else
1026             /* TODO: Should we check instead that there are only trailing
1027                blanks here, as is done below for exponents?  */
1028             goto done;
1029           /* Fall through.  */
1030         case '0':
1031         case '1':
1032         case '2':
1033         case '3':
1034         case '4':
1035         case '5':
1036         case '6':
1037         case '7':
1038         case '8':
1039         case '9':
1040           *(out++) = *p;
1041 found_digit:
1042           if (!seen_dp)
1043             seen_int_digit = 1;
1044           else
1045             seen_dec_digit = 1;
1046           break;
1047
1048         case '-':
1049         case '+':
1050           goto exponent;
1051
1052         case 'e':
1053         case 'E':
1054         case 'd':
1055         case 'D':
1056         case 'q':
1057         case 'Q':
1058           ++p;
1059           --w;
1060           goto exponent;
1061
1062         default:
1063           goto bad_float;
1064         }
1065
1066       ++p;
1067       --w;
1068     }
1069
1070   /* No exponent has been seen, so we use the current scale factor.  */
1071   exponent = - dtp->u.p.scale_factor;
1072   goto done;
1073
1074   /* At this point the start of an exponent has been found.  */
1075 exponent:
1076   p = eat_leading_spaces (&w, (char*) p);
1077   if (*p == '-' || *p == '+')
1078     {
1079       if (*p == '-')
1080         exponent_sign = -1;
1081       ++p;
1082       --w;
1083     }
1084
1085   /* At this point a digit string is required.  We calculate the value
1086      of the exponent in order to take account of the scale factor and
1087      the d parameter before explict conversion takes place.  */
1088
1089   if (w == 0)
1090     goto bad_float;
1091
1092   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1093     {
1094       while (w > 0 && isdigit (*p))
1095         {
1096           exponent *= 10;
1097           exponent += *p - '0';
1098           ++p;
1099           --w;
1100         }
1101
1102       /* Only allow trailing blanks.  */
1103       while (w > 0)
1104         {
1105           if (*p != ' ')
1106             goto bad_float;
1107           ++p;
1108           --w;
1109         }
1110     }
1111   else  /* BZ or BN status is enabled.  */
1112     {
1113       while (w > 0)
1114         {
1115           if (*p == ' ')
1116             {
1117               if (dtp->u.p.blank_status == BLANK_ZERO)
1118                 exponent *= 10;
1119               else
1120                 assert (dtp->u.p.blank_status == BLANK_NULL);
1121             }
1122           else if (!isdigit (*p))
1123             goto bad_float;
1124           else
1125             {
1126               exponent *= 10;
1127               exponent += *p - '0';
1128             }
1129
1130           ++p;
1131           --w;
1132         }
1133     }
1134
1135   exponent *= exponent_sign;
1136
1137 done:
1138   /* Use the precision specified in the format if no decimal point has been
1139      seen.  */
1140   if (!seen_dp)
1141     exponent -= f->u.real.d;
1142
1143   /* Output a trailing '0' after decimal point if not yet found.  */
1144   if (seen_dp && !seen_dec_digit)
1145     *(out++) = '0';
1146   /* Handle input of style "E+NN" by inserting a 0 for the
1147      significand.  */
1148   else if (!seen_int_digit && !seen_dec_digit)
1149     {
1150       notify_std (&dtp->common, GFC_STD_LEGACY,
1151                   "REAL input of style 'E+NN'");
1152       *(out++) = '0';
1153     }
1154
1155   /* Print out the exponent to finish the reformatted number.  Maximum 4
1156      digits for the exponent.  */
1157   if (exponent != 0)
1158     {
1159       int dig;
1160
1161       *(out++) = 'e';
1162       if (exponent < 0)
1163         {
1164           *(out++) = '-';
1165           exponent = - exponent;
1166         }
1167
1168       if (exponent >= 10000)
1169         goto bad_float;
1170
1171       for (dig = 3; dig >= 0; --dig)
1172         {
1173           out[dig] = (char) ('0' + exponent % 10);
1174           exponent /= 10;
1175         }
1176       out += 4;
1177     }
1178   *(out++) = '\0';
1179
1180   /* Do the actual conversion.  */
1181   convert_real (dtp, dest, buffer, length);
1182   if (buf_size > READF_TMP)
1183     free (buffer);
1184   return;
1185
1186   /* The value read is zero.  */
1187 zero:
1188   switch (length)
1189     {
1190       case 4:
1191         *((GFC_REAL_4 *) dest) = 0.0;
1192         break;
1193
1194       case 8:
1195         *((GFC_REAL_8 *) dest) = 0.0;
1196         break;
1197
1198 #ifdef HAVE_GFC_REAL_10
1199       case 10:
1200         *((GFC_REAL_10 *) dest) = 0.0;
1201         break;
1202 #endif
1203
1204 #ifdef HAVE_GFC_REAL_16
1205       case 16:
1206         *((GFC_REAL_16 *) dest) = 0.0;
1207         break;
1208 #endif
1209
1210       default:
1211         internal_error (&dtp->common, "Unsupported real kind during IO");
1212     }
1213   return;
1214
1215 bad_float:
1216   if (buf_size > READF_TMP)
1217     free (buffer);
1218   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1219                   "Bad value during floating point read");
1220   next_record (dtp, 1);
1221   return;
1222 }
1223
1224
1225 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1226  * and never look at it. */
1227
1228 void
1229 read_x (st_parameter_dt *dtp, int n)
1230 {
1231   int length, q, q2;
1232
1233   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1234        && dtp->u.p.current_unit->bytes_left < n)
1235     n = dtp->u.p.current_unit->bytes_left;
1236
1237   if (n == 0)
1238     return;
1239
1240   length = n;
1241
1242   if (is_internal_unit (dtp))
1243     {
1244       mem_alloc_r (dtp->u.p.current_unit->s, &length);
1245       if (unlikely (length < n))
1246         n = length;
1247       goto done;
1248     }
1249
1250   if (dtp->u.p.sf_seen_eor)
1251     return;
1252
1253   n = 0;
1254   while (n < length)
1255     {
1256       q = fbuf_getc (dtp->u.p.current_unit);
1257       if (q == EOF)
1258         break;
1259       else if (q == '\n' || q == '\r')
1260         {
1261           /* Unexpected end of line. Set the position.  */
1262           dtp->u.p.sf_seen_eor = 1;
1263
1264           /* If we see an EOR during non-advancing I/O, we need to skip
1265              the rest of the I/O statement.  Set the corresponding flag.  */
1266           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1267             dtp->u.p.eor_condition = 1;
1268
1269           /* If we encounter a CR, it might be a CRLF.  */
1270           if (q == '\r') /* Probably a CRLF */
1271             {
1272               /* See if there is an LF.  */
1273               q2 = fbuf_getc (dtp->u.p.current_unit);
1274               if (q2 == '\n')
1275                 dtp->u.p.sf_seen_eor = 2;
1276               else if (q2 != EOF) /* Oops, seek back.  */
1277                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1278             }
1279           goto done;
1280         }
1281       n++;
1282     }
1283
1284  done:
1285   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1286     dtp->u.p.size_used += (GFC_IO_INT) n;
1287   dtp->u.p.current_unit->bytes_left -= n;
1288   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1289 }
1290