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