libgfortran/io/read.c

   1 /* Copyright (C) 2002-2003 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 In addition to the permissions in the GNU General Public License, the
  12 Free Software Foundation gives you unlimited permission to link the
  13 compiled version of this file into combinations with other programs,
  14 and to distribute those combinations without any restriction coming
  15 from the use of this file.  (The General Public License restrictions
  16 do apply in other respects; for example, they cover modification of
  17 the file, and distribution when not linked into a combine
  18 executable.)
  19
  20 Libgfortran is distributed in the hope that it will be useful,
  21 but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 GNU General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public License
  26 along with Libgfortran; see the file COPYING.  If not, write to
  27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  28 Boston, MA 02110-1301, USA.  */
  29
  30
  31 #include "config.h"
  32 #include <string.h>
  33 #include <errno.h>
  34 #include <ctype.h>
  35 #include <stdlib.h>
  36 #include <stdio.h>
  37 #include "libgfortran.h"
  38 #include "io.h"
  39
  40 /* read.c -- Deal with formatted reads */
  41
  42 /* set_integer()-- All of the integer assignments come here to
  43  * actually place the value into memory.  */
  44
  45 void
  46 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
  47 {
  48   switch (length)
  49     {
  50 #ifdef HAVE_GFC_INTEGER_16
  51     case 16:
  52       *((GFC_INTEGER_16 *) dest) = value;
  53       break;
  54 #endif
  55     case 8:
  56       *((GFC_INTEGER_8 *) dest) = value;
  57       break;
  58     case 4:
  59       *((GFC_INTEGER_4 *) dest) = value;
  60       break;
  61     case 2:
  62       *((GFC_INTEGER_2 *) dest) = value;
  63       break;
  64     case 1:
  65       *((GFC_INTEGER_1 *) dest) = value;
  66       break;
  67     default:
  68       internal_error ("Bad integer kind");
  69     }
  70 }
  71
  72
  73 /* max_value()-- Given a length (kind), return the maximum signed or
  74  * unsigned value */
  75
  76 GFC_UINTEGER_LARGEST
  77 max_value (int length, int signed_flag)
  78 {
  79   GFC_UINTEGER_LARGEST value;
  80   int n;
  81
  82   switch (length)
  83     {
  84 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
  85     case 16:
  86     case 10:
  87       value = 1;
  88       for (n = 1; n < 4 * length; n++)
  89         value = (value << 2) + 3;
  90       if (! signed_flag)
  91         value = 2*value+1;
  92       break;
  93 #endif
  94     case 8:
  95       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
  96       break;
  97     case 4:
  98       value = signed_flag ? 0x7fffffff : 0xffffffff;
  99       break;
 100     case 2:
 101       value = signed_flag ? 0x7fff : 0xffff;
 102       break;
 103     case 1:
 104       value = signed_flag ? 0x7f : 0xff;
 105       break;
 106     default:
 107       internal_error ("Bad integer kind");
 108     }
 109
 110   return value;
 111 }
 112
 113
 114 /* convert_real()-- Convert a character representation of a floating
 115  * point number to the machine number.  Returns nonzero if there is a
 116  * range problem during conversion.  TODO: handle not-a-numbers and
 117  * infinities.  */
 118
 119 int
 120 convert_real (void *dest, const char *buffer, int length)
 121 {
 122   errno = 0;
 123
 124   switch (length)
 125     {
 126     case 4:
 127       *((GFC_REAL_4 *) dest) =
 128 #if defined(HAVE_STRTOF)
 129         strtof (buffer, NULL);
 130 #else
 131         (GFC_REAL_4) strtod (buffer, NULL);
 132 #endif
 133       break;
 134     case 8:
 135       *((GFC_REAL_8 *) dest) = strtod (buffer, NULL);
 136       break;
 137 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
 138     case 10:
 139       *((GFC_REAL_10 *) dest) = strtold (buffer, NULL);
 140       break;
 141 #endif
 142 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
 143     case 16:
 144       *((GFC_REAL_16 *) dest) = strtold (buffer, NULL);
 145       break;
 146 #endif
 147     default:
 148       internal_error ("Unsupported real kind during IO");
 149     }
 150
 151   if (errno != 0 && errno != EINVAL)
 152     {
 153       generate_error (ERROR_READ_VALUE,
 154                       "Range error during floating point read");
 155       return 1;
 156     }
 157
 158   return 0;
 159 }
 160
 161
 162 /* read_l()-- Read a logical value */
 163
 164 void
 165 read_l (fnode * f, char *dest, int length)
 166 {
 167   char *p;
 168   int w;
 169
 170   w = f->u.w;
 171   p = read_block (&w);
 172   if (p == NULL)
 173     return;
 174
 175   while (*p == ' ')
 176     {
 177       if (--w == 0)
 178         goto bad;
 179       p++;
 180     }
 181
 182   if (*p == '.')
 183     {
 184       if (--w == 0)
 185         goto bad;
 186       p++;
 187     }
 188
 189   switch (*p)
 190     {
 191     case 't':
 192     case 'T':
 193       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
 194       break;
 195     case 'f':
 196     case 'F':
 197       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 198       break;
 199     default:
 200     bad:
 201       generate_error (ERROR_READ_VALUE, "Bad value on logical read");
 202       break;
 203     }
 204 }
 205
 206
 207 /* read_a()-- Read a character record.  This one is pretty easy. */
 208
 209 void
 210 read_a (fnode * f, char *p, int length)
 211 {
 212   char *source;
 213   int w, m, n;
 214
 215   w = f->u.w;
 216   if (w == -1) /* '(A)' edit descriptor  */
 217     w = length;
 218
 219   source = read_block (&w);
 220   if (source == NULL)
 221     return;
 222   if (w > length)
 223      source += (w - length);
 224
 225   m = (w > length) ? length : w;
 226   memcpy (p, source, m);
 227
 228   n = length - w;
 229   if (n > 0)
 230     memset (p + m, ' ', n);
 231 }
 232
 233
 234 /* eat_leading_spaces()-- Given a character pointer and a width,
 235  * ignore the leading spaces.  */
 236
 237 static char *
 238 eat_leading_spaces (int *width, char *p)
 239 {
 240   for (;;)
 241     {
 242       if (*width == 0 || *p != ' ')
 243         break;
 244
 245       (*width)--;
 246       p++;
 247     }
 248
 249   return p;
 250 }
 251
 252
 253 static char
 254 next_char (char **p, int *w)
 255 {
 256   char c, *q;
 257
 258   if (*w == 0)
 259     return '\0';
 260
 261   q = *p;
 262   c = *q++;
 263   *p = q;
 264
 265   (*w)--;
 266
 267   if (c != ' ')
 268     return c;
 269   if (g.blank_status != BLANK_UNSPECIFIED)
 270     return ' ';  /* return a blank to signal a null */
 271
 272   /* At this point, the rest of the field has to be trailing blanks */
 273
 274   while (*w > 0)
 275     {
 276       if (*q++ != ' ')
 277         return '?';
 278       (*w)--;
 279     }
 280
 281   *p = q;
 282   return '\0';
 283 }
 284
 285
 286 /* read_decimal()-- Read a decimal integer value.  The values here are
 287  * signed values. */
 288
 289 void
 290 read_decimal (fnode * f, char *dest, int length)
 291 {
 292   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 293   GFC_INTEGER_LARGEST v;
 294   int w, negative;
 295   char c, *p;
 296
 297   w = f->u.w;
 298   p = read_block (&w);
 299   if (p == NULL)
 300     return;
 301
 302   p = eat_leading_spaces (&w, p);
 303   if (w == 0)
 304     {
 305       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 306       return;
 307     }
 308
 309   maxv = max_value (length, 1);
 310   maxv_10 = maxv / 10;
 311
 312   negative = 0;
 313   value = 0;
 314
 315   switch (*p)
 316     {
 317     case '-':
 318       negative = 1;
 319       /* Fall through */
 320
 321     case '+':
 322       p++;
 323       if (--w == 0)
 324         goto bad;
 325       /* Fall through */
 326
 327     default:
 328       break;
 329     }
 330
 331   /* At this point we have a digit-string */
 332   value = 0;
 333
 334   for (;;)
 335     {
 336       c = next_char (&p, &w);
 337       if (c == '\0')
 338         break;
 339
 340       if (c == ' ')
 341         {
 342           if (g.blank_status == BLANK_NULL) continue;
 343           if (g.blank_status == BLANK_ZERO) c = '0';
 344         }
 345
 346       if (c < '0' || c > '9')
 347         goto bad;
 348
 349       if (value > maxv_10)
 350         goto overflow;
 351
 352       c -= '0';
 353       value = 10 * value;
 354
 355       if (value > maxv - c)
 356         goto overflow;
 357       value += c;
 358     }
 359
 360   v = value;
 361   if (negative)
 362     v = -v;
 363
 364   set_integer (dest, v, length);
 365   return;
 366
 367  bad:
 368   generate_error (ERROR_READ_VALUE, "Bad value during integer read");
 369   return;
 370
 371  overflow:
 372   generate_error (ERROR_READ_OVERFLOW,
 373                   "Value overflowed during integer read");
 374   return;
 375 }
 376
 377
 378 /* read_radix()-- This function reads values for non-decimal radixes.
 379  * The difference here is that we treat the values here as unsigned
 380  * values for the purposes of overflow.  If minus sign is present and
 381  * the top bit is set, the value will be incorrect. */
 382
 383 void
 384 read_radix (fnode * f, char *dest, int length, int radix)
 385 {
 386   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 387   GFC_INTEGER_LARGEST v;
 388   int w, negative;
 389   char c, *p;
 390
 391   w = f->u.w;
 392   p = read_block (&w);
 393   if (p == NULL)
 394     return;
 395
 396   p = eat_leading_spaces (&w, p);
 397   if (w == 0)
 398     {
 399       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 400       return;
 401     }
 402
 403   maxv = max_value (length, 0);
 404   maxv_r = maxv / radix;
 405
 406   negative = 0;
 407   value = 0;
 408
 409   switch (*p)
 410     {
 411     case '-':
 412       negative = 1;
 413       /* Fall through */
 414
 415     case '+':
 416       p++;
 417       if (--w == 0)
 418         goto bad;
 419       /* Fall through */
 420
 421     default:
 422       break;
 423     }
 424
 425   /* At this point we have a digit-string */
 426   value = 0;
 427
 428   for (;;)
 429     {
 430       c = next_char (&p, &w);
 431       if (c == '\0')
 432         break;
 433       if (c == ' ')
 434         {
 435           if (g.blank_status == BLANK_NULL) continue;
 436           if (g.blank_status == BLANK_ZERO) c = '0';
 437         }
 438
 439       switch (radix)
 440         {
 441         case 2:
 442           if (c < '0' || c > '1')
 443             goto bad;
 444           break;
 445
 446         case 8:
 447           if (c < '0' || c > '7')
 448             goto bad;
 449           break;
 450
 451         case 16:
 452           switch (c)
 453             {
 454             case '0':
 455             case '1':
 456             case '2':
 457             case '3':
 458             case '4':
 459             case '5':
 460             case '6':
 461             case '7':
 462             case '8':
 463             case '9':
 464               break;
 465
 466             case 'a':
 467             case 'b':
 468             case 'c':
 469             case 'd':
 470             case 'e':
 471             case 'f':
 472               c = c - 'a' + '9' + 1;
 473               break;
 474
 475             case 'A':
 476             case 'B':
 477             case 'C':
 478             case 'D':
 479             case 'E':
 480             case 'F':
 481               c = c - 'A' + '9' + 1;
 482               break;
 483
 484             default:
 485               goto bad;
 486             }
 487
 488           break;
 489         }
 490
 491       if (value > maxv_r)
 492         goto overflow;
 493
 494       c -= '0';
 495       value = radix * value;
 496
 497       if (maxv - c < value)
 498         goto overflow;
 499       value += c;
 500     }
 501
 502   v = value;
 503   if (negative)
 504     v = -v;
 505
 506   set_integer (dest, v, length);
 507   return;
 508
 509  bad:
 510   generate_error (ERROR_READ_VALUE, "Bad value during integer read");
 511   return;
 512
 513  overflow:
 514   generate_error (ERROR_READ_OVERFLOW,
 515                   "Value overflowed during integer read");
 516   return;
 517 }
 518
 519
 520 /* read_f()-- Read a floating point number with F-style editing, which
 521    is what all of the other floating point descriptors behave as.  The
 522    tricky part is that optional spaces are allowed after an E or D,
 523    and the implicit decimal point if a decimal point is not present in
 524    the input.  */
 525
 526 void
 527 read_f (fnode * f, char *dest, int length)
 528 {
 529   int w, seen_dp, exponent;
 530   int exponent_sign, val_sign;
 531   int ndigits;
 532   int edigits;
 533   int i;
 534   char *p, *buffer;
 535   char *digits;
 536
 537   val_sign = 1;
 538   seen_dp = 0;
 539   w = f->u.w;
 540   p = read_block (&w);
 541   if (p == NULL)
 542     return;
 543
 544   p = eat_leading_spaces (&w, p);
 545   if (w == 0)
 546     goto zero;
 547
 548   /* Optional sign */
 549
 550   if (*p == '-' || *p == '+')
 551     {
 552       if (*p == '-')
 553         val_sign = -1;
 554       p++;
 555       w--;
 556     }
 557
 558   exponent_sign = 1;
 559   p = eat_leading_spaces (&w, p);
 560   if (w == 0)
 561     goto zero;
 562
 563   /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
 564      is required at this point */
 565
 566   if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
 567       && *p != 'e' && *p != 'E')
 568     goto bad_float;
 569
 570   /* Remember the position of the first digit.  */
 571   digits = p;
 572   ndigits = 0;
 573
 574   /* Scan through the string to find the exponent.  */
 575   while (w > 0)
 576     {
 577       switch (*p)
 578         {
 579         case '.':
 580           if (seen_dp)
 581             goto bad_float;
 582           seen_dp = 1;
 583           /* Fall through */
 584
 585         case '0':
 586         case '1':
 587         case '2':
 588         case '3':
 589         case '4':
 590         case '5':
 591         case '6':
 592         case '7':
 593         case '8':
 594         case '9':
 595         case ' ':
 596           ndigits++;
 597           *p++;
 598           w--;
 599           break;
 600
 601         case '-':
 602           exponent_sign = -1;
 603           /* Fall through */
 604
 605         case '+':
 606           p++;
 607           w--;
 608           goto exp2;
 609
 610         case 'd':
 611         case 'e':
 612         case 'D':
 613         case 'E':
 614           p++;
 615           w--;
 616           goto exp1;
 617
 618         default:
 619           goto bad_float;
 620         }
 621     }
 622
 623   /* No exponent has been seen, so we use the current scale factor */
 624   exponent = -g.scale_factor;
 625   goto done;
 626
 627  bad_float:
 628   generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
 629   return;
 630
 631   /* The value read is zero */
 632  zero:
 633   switch (length)
 634     {
 635       case 4:
 636         *((GFC_REAL_4 *) dest) = 0;
 637         break;
 638
 639       case 8:
 640         *((GFC_REAL_8 *) dest) = 0;
 641         break;
 642
 643 #ifdef HAVE_GFC_REAL_10
 644       case 10:
 645         *((GFC_REAL_10 *) dest) = 0;
 646         break;
 647 #endif
 648
 649 #ifdef HAVE_GFC_REAL_16
 650       case 16:
 651         *((GFC_REAL_16 *) dest) = 0;
 652         break;
 653 #endif
 654
 655       default:
 656         internal_error ("Unsupported real kind during IO");
 657     }
 658   return;
 659
 660   /* At this point the start of an exponent has been found */
 661  exp1:
 662   while (w > 0 && *p == ' ')
 663     {
 664       w--;
 665       p++;
 666     }
 667
 668   switch (*p)
 669     {
 670     case '-':
 671       exponent_sign = -1;
 672       /* Fall through */
 673
 674     case '+':
 675       p++;
 676       w--;
 677       break;
 678     }
 679
 680   if (w == 0)
 681     goto bad_float;
 682
 683   /* At this point a digit string is required.  We calculate the value
 684      of the exponent in order to take account of the scale factor and
 685      the d parameter before explict conversion takes place. */
 686  exp2:
 687   if (!isdigit (*p))
 688     goto bad_float;
 689
 690   exponent = *p - '0';
 691   p++;
 692   w--;
 693
 694   if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
 695     {
 696       while (w > 0 && isdigit (*p))
 697         {
 698           exponent = 10 * exponent + *p - '0';
 699           p++;
 700           w--;
 701         }
 702
 703       /* Only allow trailing blanks */
 704
 705       while (w > 0)
 706         {
 707           if (*p != ' ')
 708           goto bad_float;
 709           p++;
 710           w--;
 711         }
 712     }
 713   else  /* BZ or BN status is enabled */
 714     {
 715       while (w > 0)
 716         {
 717           if (*p == ' ')
 718             {
 719               if (g.blank_status == BLANK_ZERO) *p = '0';
 720               if (g.blank_status == BLANK_NULL)
 721                 {
 722                   p++;
 723                   w--;
 724                   continue;
 725                 }
 726             }
 727           else if (!isdigit (*p))
 728             goto bad_float;
 729
 730           exponent = 10 * exponent + *p - '0';
 731           p++;
 732           w--;
 733         }
 734     }
 735
 736   exponent = exponent * exponent_sign;
 737
 738  done:
 739   /* Use the precision specified in the format if no decimal point has been
 740      seen.  */
 741   if (!seen_dp)
 742     exponent -= f->u.real.d;
 743
 744   if (exponent > 0)
 745     {
 746       edigits = 2;
 747       i = exponent;
 748     }
 749   else
 750     {
 751       edigits = 3;
 752       i = -exponent;
 753     }
 754
 755   while (i >= 10)
 756     {
 757       i /= 10;
 758       edigits++;
 759     }
 760
 761   i = ndigits + edigits + 1;
 762   if (val_sign < 0)
 763     i++;
 764
 765   if (i < SCRATCH_SIZE)
 766     buffer = scratch;
 767   else
 768     buffer = get_mem (i);
 769
 770   /* Reformat the string into a temporary buffer.  As we're using atof it's
 771      easiest to just leave the decimal point in place.  */
 772   p = buffer;
 773   if (val_sign < 0)
 774     *(p++) = '-';
 775   for (; ndigits > 0; ndigits--)
 776     {
 777       if (*digits == ' ')
 778         {
 779           if (g.blank_status == BLANK_ZERO) *digits = '0';
 780           if (g.blank_status == BLANK_NULL)
 781             {
 782               digits++;
 783               continue;
 784             }
 785         }
 786       *p = *digits;
 787       p++;
 788       digits++;
 789     }
 790   *(p++) = 'e';
 791   sprintf (p, "%d", exponent);
 792
 793   /* Do the actual conversion.  */
 794   convert_real (dest, buffer, length);
 795
 796   if (buffer != scratch)
 797      free_mem (buffer);
 798
 799   return;
 800 }
 801
 802
 803 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
 804  * and never look at it. */
 805
 806 void
 807 read_x (fnode * f)
 808 {
 809   int n;
 810
 811   n = f->u.n;
 812
 813   if ((current_unit->flags.pad == PAD_NO || is_internal_unit ())
 814       && current_unit->bytes_left < n)
 815     n = current_unit->bytes_left;
 816
 817   if (n > 0)
 818     read_block (&n);
 819 }