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