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