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