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