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     goto zero;
 508
 509   /* Optional sign */
 510
 511   if (*p == '-' || *p == '+')
 512     {
 513       if (*p == '-')
 514         val_sign = -1;
 515       p++;
 516       w--;
 517     }
 518
 519   exponent_sign = 1;
 520   p = eat_leading_spaces (&w, p);
 521   if (w == 0)
 522     goto zero;
 523
 524   /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
 525      is required at this point */
 526
 527   if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
 528       && *p != 'e' && *p != 'E')
 529     goto bad_float;
 530
 531   /* Remember the position of the first digit.  */
 532   digits = p;
 533   ndigits = 0;
 534
 535   /* Scan through the string to find the exponent.  */
 536   while (w > 0)
 537     {
 538       switch (*p)
 539         {
 540         case '.':
 541           if (seen_dp)
 542             goto bad_float;
 543           seen_dp = 1;
 544           /* Fall through */
 545
 546         case '0':
 547         case '1':
 548         case '2':
 549         case '3':
 550         case '4':
 551         case '5':
 552         case '6':
 553         case '7':
 554         case '8':
 555         case '9':
 556         case ' ':
 557           ndigits++;
 558           *p++;
 559           w--;
 560           break;
 561
 562         case '-':
 563           exponent_sign = -1;
 564           /* Fall through */
 565
 566         case '+':
 567           p++;
 568           w--;
 569           goto exp2;
 570
 571         case 'd':
 572         case 'e':
 573         case 'D':
 574         case 'E':
 575           p++;
 576           w--;
 577           goto exp1;
 578
 579         default:
 580           goto bad_float;
 581         }
 582     }
 583
 584   /* No exponent has been seen, so we use the current scale factor */
 585   exponent = -g.scale_factor;
 586   goto done;
 587
 588  bad_float:
 589   generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
 590   return;
 591
 592   /* The value read is zero */
 593  zero:
 594   switch (length)
 595     {
 596       case 4:
 597         *((float *) dest) = 0.0f;
 598         break;
 599
 600       case 8:
 601         *((double *) dest) = 0.0;
 602         break;
 603
 604       default:
 605         internal_error ("Unsupported real kind during IO");
 606     }
 607   return;
 608
 609   /* At this point the start of an exponent has been found */
 610  exp1:
 611   while (w > 0 && *p == ' ')
 612     {
 613       w--;
 614       p++;
 615     }
 616
 617   switch (*p)
 618     {
 619     case '-':
 620       exponent_sign = -1;
 621       /* Fall through */
 622
 623     case '+':
 624       p++;
 625       w--;
 626       break;
 627     }
 628
 629   if (w == 0)
 630     goto bad_float;
 631
 632   /* At this point a digit string is required.  We calculate the value
 633      of the exponent in order to take account of the scale factor and
 634      the d parameter before explict conversion takes place. */
 635  exp2:
 636   if (!isdigit (*p))
 637     goto bad_float;
 638
 639   exponent = *p - '0';
 640   p++;
 641   w--;
 642
 643   while (w > 0 && isdigit (*p))
 644     {
 645       exponent = 10 * exponent + *p - '0';
 646       p++;
 647       w--;
 648     }
 649
 650   /* Only allow trailing blanks */
 651
 652   while (w > 0)
 653     {
 654       if (*p != ' ')
 655         goto bad_float;
 656       p++;
 657       w--;
 658     }
 659
 660   exponent = exponent * exponent_sign;
 661
 662  done:
 663   /* Use the precision specified in the format if no decimal point has been
 664      seen.  */
 665   if (!seen_dp)
 666     exponent -= f->u.real.d;
 667
 668   if (exponent > 0)
 669     {
 670       edigits = 2;
 671       i = exponent;
 672     }
 673   else
 674     {
 675       edigits = 3;
 676       i = -exponent;
 677     }
 678
 679   while (i >= 10)
 680     {
 681       i /= 10;
 682       edigits++;
 683     }
 684
 685   i = ndigits + edigits + 1;
 686   if (val_sign < 0)
 687     i++;
 688
 689   if (i < SCRATCH_SIZE)
 690     buffer = scratch;
 691   else
 692     buffer = get_mem (i);
 693
 694   /* Reformat the string into a temporary buffer.  As we're using atof it's
 695      easiest to just leave the dcimal point in place.  */
 696   p = buffer;
 697   if (val_sign < 0)
 698     *(p++) = '-';
 699   for (; ndigits > 0; ndigits--)
 700     {
 701       if (*digits == ' ' && g.blank_status == BLANK_ZERO)
 702         *p = '0';
 703       else
 704         *p = *digits;
 705       p++;
 706       digits++;
 707     }
 708   *(p++) = 'e';
 709   sprintf (p, "%d", exponent);
 710
 711   /* Do the actual conversion.  */
 712   convert_real (dest, buffer, length);
 713
 714   if (buffer != scratch)
 715      free_mem (buffer);
 716
 717   return;
 718 }
 719
 720
 721 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
 722  * and never look at it. */
 723
 724 void
 725 read_x (fnode * f)
 726 {
 727   int n;
 728
 729   n = f->u.n;
 730   read_block (&n);
 731 }