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 "libgfortran.h"
  28 #include "io.h"
  29
  30 /* read.c -- Deal with formatted reads */
  31
  32 /* set_integer()-- All of the integer assignments come here to
  33  * actually place the value into memory.  */
  34
  35 void
  36 set_integer (void *dest, int64_t value, int length)
  37 {
  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.  Handling of kind 4 is probably wrong because of double
  93  * rounding. */
  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) = (float) strtod (buffer, NULL);
 105       break;
 106     case 8:
 107       *((double *) dest) = strtod (buffer, NULL);
 108       break;
 109     default:
 110       internal_error ("Bad real number kind");
 111     }
 112
 113   if (errno != 0)
 114     {
 115       generate_error (ERROR_READ_VALUE,
 116                       "Range error during floating point read");
 117       return 1;
 118     }
 119
 120   return 0;
 121 }
 122
 123 static int
 124 convert_precision_real (void *dest, int sign,
 125                        char *buffer, int length, int exponent)
 126 {
 127   int w, new_dp_pos, i, slen, k, dp;
 128   char * p, c;
 129   double fval;
 130   float tf;
 131
 132   fval =0.0;
 133   tf = 0.0;
 134   dp = 0;
 135   new_dp_pos = 0;
 136
 137   slen = strlen (buffer);
 138   w = slen;
 139   p = buffer;
 140
 141 /*  for (i = w - 1; i > 0; i --)
 142     {
 143        if (buffer[i] == '0' || buffer[i] == 0)
 144          buffer[i] = 0;
 145        else
 146          break;
 147     }
 148 */
 149   for (i = 0; i < w; i++)
 150     {
 151        if (buffer[i] == '.')
 152          break;
 153     }
 154
 155   new_dp_pos = i;
 156   new_dp_pos += exponent;
 157
 158   while (w > 0)
 159     {
 160       c = *p;
 161       switch (c)
 162         {
 163         case '0':
 164         case '1':
 165         case '2':
 166         case '3':
 167         case '4':
 168         case '5':
 169         case '6':
 170         case '7':
 171         case '8':
 172         case '9':
 173           fval = fval * 10.0 + c - '0';
 174           p++;
 175           w--;
 176           break;
 177
 178         case '.':
 179           dp = 1;
 180           p++;
 181           w--;
 182           break;
 183
 184        default:
 185           p++;
 186           w--;
 187           break;
 188      }
 189   }
 190
 191   if (sign)
 192     fval = - fval;
 193
 194   i = new_dp_pos - slen + dp;
 195   k = abs(i);
 196   tf = 1.0;
 197
 198   while (k > 0)
 199     {
 200        tf *= 10.0 ;
 201        k -- ;
 202     }
 203
 204   if (fval != 0.0)
 205     {
 206        if (i < 0)
 207          {
 208            fval = fval / tf;
 209          }
 210         else
 211          {
 212            fval = fval * tf;
 213          }
 214     }
 215
 216   switch (length)
 217     {
 218     case 4:
 219       *((float *) dest) = (float)fval;
 220       break;
 221     case 8:
 222       *((double *) dest) = fval;
 223       break;
 224     default:
 225       internal_error ("Bad real number kind");
 226     }
 227
 228   return 0;
 229 }
 230
 231
 232 /* read_l()-- Read a logical value */
 233
 234 void
 235 read_l (fnode * f, char *dest, int length)
 236 {
 237   char *p;
 238   int w;
 239
 240   w = f->u.w;
 241   p = read_block (&w);
 242   if (p == NULL)
 243     return;
 244
 245   while (*p == ' ')
 246     {
 247       if (--w == 0)
 248         goto bad;
 249       p++;
 250     }
 251
 252   if (*p == '.')
 253     {
 254       if (--w == 0)
 255         goto bad;
 256       p++;
 257     }
 258
 259   switch (*p)
 260     {
 261     case 't':
 262     case 'T':
 263       set_integer (dest, 1, length);
 264       break;
 265     case 'f':
 266     case 'F':
 267       set_integer (dest, 0, length);
 268       break;
 269     default:
 270     bad:
 271       generate_error (ERROR_READ_VALUE, "Bad value on logical read");
 272       break;
 273     }
 274 }
 275
 276
 277 /* read_a()-- Read a character record.  This one is pretty easy. */
 278
 279 void
 280 read_a (fnode * f, char *p, int length)
 281 {
 282   char *source;
 283   int w, m, n;
 284
 285   w = f->u.w;
 286   if (w == -1) /* '(A)' edit descriptor  */
 287     w = length;
 288
 289   source = read_block (&w);
 290   if (source == NULL)
 291     return;
 292   if (w > length)
 293      source += (w - length);
 294
 295   m = (w > length) ? length : w;
 296   memcpy (p, source, m);
 297
 298   n = length - w;
 299   if (n > 0)
 300     memset (p + m, ' ', n);
 301 }
 302
 303
 304 /* eat_leading_spaces()-- Given a character pointer and a width,
 305  * ignore the leading spaces.  */
 306
 307 static char *
 308 eat_leading_spaces (int *width, char *p)
 309 {
 310
 311   for (;;)
 312     {
 313       if (*width == 0 || *p != ' ')
 314         break;
 315
 316       (*width)--;
 317       p++;
 318     }
 319
 320   return p;
 321 }
 322
 323
 324 static char
 325 next_char (char **p, int *w)
 326 {
 327   char c, *q;
 328
 329   if (*w == 0)
 330     return '\0';
 331
 332   q = *p;
 333   c = *q++;
 334   *p = q;
 335
 336   (*w)--;
 337
 338   if (c != ' ')
 339     return c;
 340   if (g.blank_status == BLANK_ZERO)
 341     return '0';
 342
 343   /* At this point, the rest of the field has to be trailing blanks */
 344
 345   while (*w > 0)
 346     {
 347       if (*q++ != ' ')
 348         return '?';
 349       (*w)--;
 350     }
 351
 352   *p = q;
 353   return '\0';
 354 }
 355
 356
 357 /* read_decimal()-- Read a decimal integer value.  The values here are
 358  * signed values. */
 359
 360 void
 361 read_decimal (fnode * f, char *dest, int length)
 362 {
 363   unsigned value, maxv, maxv_10;
 364   int v, w, negative;
 365   char c, *p;
 366
 367   w = f->u.w;
 368   p = read_block (&w);
 369   if (p == NULL)
 370     return;
 371
 372   p = eat_leading_spaces (&w, p);
 373   if (w == 0)
 374     {
 375       set_integer (dest, 0, length);
 376       return;
 377     }
 378
 379   maxv = max_value (length, 1);
 380   maxv_10 = maxv / 10;
 381
 382   negative = 0;
 383   value = 0;
 384
 385   switch (*p)
 386     {
 387     case '-':
 388       negative = 1;
 389       /* Fall through */
 390
 391     case '+':
 392       p++;
 393       if (--w == 0)
 394         goto bad;
 395       /* Fall through */
 396
 397     default:
 398       break;
 399     }
 400
 401   /* At this point we have a digit-string */
 402   value = 0;
 403
 404   for (;;)
 405     {
 406       c = next_char (&p, &w);
 407       if (c == '\0')
 408         break;
 409
 410       if (c < '0' || c > '9')
 411         goto bad;
 412
 413       if (value > maxv_10)
 414         goto overflow;
 415
 416       c -= '0';
 417       value = 10 * value;
 418
 419       if (value > maxv - c)
 420         goto overflow;
 421       value += c;
 422     }
 423
 424   v = (signed int) value;
 425   if (negative)
 426     v = -v;
 427
 428   set_integer (dest, v, length);
 429   return;
 430
 431 bad:
 432   generate_error (ERROR_READ_VALUE, "Bad value during integer read");
 433   return;
 434
 435 overflow:
 436   generate_error (ERROR_READ_OVERFLOW,
 437                   "Value overflowed during integer read");
 438   return;
 439 }
 440
 441
 442 /* read_radix()-- This function reads values for non-decimal radixes.
 443  * The difference here is that we treat the values here as unsigned
 444  * values for the purposes of overflow.  If minus sign is present and
 445  * the top bit is set, the value will be incorrect. */
 446
 447 void
 448 read_radix (fnode * f, char *dest, int length, int radix)
 449 {
 450   unsigned value, maxv, maxv_r;
 451   int v, w, negative;
 452   char c, *p;
 453
 454   w = f->u.w;
 455   p = read_block (&w);
 456   if (p == NULL)
 457     return;
 458
 459   p = eat_leading_spaces (&w, p);
 460   if (w == 0)
 461     {
 462       set_integer (dest, 0, length);
 463       return;
 464     }
 465
 466   maxv = max_value (length, 0);
 467   maxv_r = maxv / radix;
 468
 469   negative = 0;
 470   value = 0;
 471
 472   switch (*p)
 473     {
 474     case '-':
 475       negative = 1;
 476       /* Fall through */
 477
 478     case '+':
 479       p++;
 480       if (--w == 0)
 481         goto bad;
 482       /* Fall through */
 483
 484     default:
 485       break;
 486     }
 487
 488   /* At this point we have a digit-string */
 489   value = 0;
 490
 491   for (;;)
 492     {
 493       c = next_char (&p, &w);
 494       if (c == '\0')
 495         break;
 496
 497       switch (radix)
 498         {
 499         case 2:
 500           if (c < '0' || c > '1')
 501             goto bad;
 502           break;
 503
 504         case 8:
 505           if (c < '0' || c > '7')
 506             goto bad;
 507           break;
 508
 509         case 16:
 510           switch (c)
 511             {
 512             case '0':
 513             case '1':
 514             case '2':
 515             case '3':
 516             case '4':
 517             case '5':
 518             case '6':
 519             case '7':
 520             case '8':
 521             case '9':
 522               break;
 523
 524             case 'a':
 525             case 'b':
 526             case 'c':
 527             case 'd':
 528             case 'e':
 529               c = c - 'a' + '9' + 1;
 530               break;
 531
 532             case 'A':
 533             case 'B':
 534             case 'C':
 535             case 'D':
 536             case 'E':
 537               c = c - 'A' + '9' + 1;
 538               break;
 539
 540             default:
 541               goto bad;
 542             }
 543
 544           break;
 545         }
 546
 547       if (value > maxv_r)
 548         goto overflow;
 549
 550       c -= '0';
 551       value = radix * value;
 552
 553       if (maxv - c < value)
 554         goto overflow;
 555       value += c;
 556     }
 557
 558   v = (signed int) value;
 559   if (negative)
 560     v = -v;
 561
 562   set_integer (dest, v, length);
 563   return;
 564
 565 bad:
 566   generate_error (ERROR_READ_VALUE, "Bad value during integer read");
 567   return;
 568
 569 overflow:
 570   generate_error (ERROR_READ_OVERFLOW,
 571                   "Value overflowed during integer read");
 572   return;
 573 }
 574
 575
 576 /* read_f()-- Read a floating point number with F-style editing, which
 577  * is what all of the other floating point descriptors behave as.  The
 578  * tricky part is that optional spaces are allowed after an E or D,
 579  * and the implicit decimal point if a decimal point is not present in
 580  * the input. */
 581
 582 void
 583 read_f (fnode * f, char *dest, int length)
 584 {
 585   int w, seen_dp, exponent;
 586   int exponent_sign, val_sign;
 587   char *p, *buffer, *n;
 588
 589   val_sign = 0;
 590   seen_dp = 0;
 591   w = f->u.w;
 592   p = read_block (&w);
 593   if (p == NULL)
 594     return;
 595
 596   p = eat_leading_spaces (&w, p);
 597   if (w == 0)
 598     {
 599       switch (length)
 600         {
 601         case 4:
 602           *((float *) dest) = 0.0;
 603           break;
 604
 605         case 8:
 606           *((double *) dest) = 0.0;
 607           break;
 608         }
 609
 610       return;
 611     }
 612
 613   if (w + 2 < SCRATCH_SIZE)
 614     buffer = scratch;
 615   else
 616     buffer = get_mem (w + 2);
 617
 618   memset(buffer, 0, w + 2);
 619
 620   n = buffer;
 621
 622   /* Optional sign */
 623
 624   if (*p == '-' || *p == '+')
 625     {
 626       if (*p == '-')
 627         val_sign = 1;
 628       p++;
 629
 630       if (--w == 0)
 631         goto bad_float;
 632     }
 633
 634   exponent_sign = 1;
 635
 636   /* A digit (or a '.') is required at this point */
 637
 638   if (!isdigit (*p) && *p != '.')
 639     goto bad_float;
 640
 641   while (w > 0)
 642     {
 643       switch (*p)
 644         {
 645         case '0':
 646         case '1':
 647         case '2':
 648         case '3':
 649         case '4':
 650         case '5':
 651         case '6':
 652         case '7':
 653         case '8':
 654         case '9':
 655           *n++ = *p++;
 656           w--;
 657           break;
 658
 659         case '.':
 660           if (seen_dp)
 661             goto bad_float;
 662           seen_dp = 1;
 663
 664           *n++ = *p++;
 665           w--;
 666           break;
 667
 668         case ' ':
 669           if (g.blank_status == BLANK_ZERO)
 670             *n++ = '0';
 671           p++;
 672           w--;
 673           break;
 674
 675         case '-':
 676           exponent_sign = -1;
 677           /* Fall through */
 678
 679         case '+':
 680           p++;
 681           w--;
 682           goto exp2;
 683
 684         case 'd':
 685         case 'e':
 686         case 'D':
 687         case 'E':
 688           p++;
 689           w--;
 690           goto exp1;
 691
 692         default:
 693           goto bad_float;
 694         }
 695     }
 696
 697 /* No exponent has been seen, so we use the current scale factor */
 698
 699   exponent = -g.scale_factor;
 700   goto done;
 701
 702 bad_float:
 703   generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
 704   if (buffer != scratch)
 705      free_mem (buffer);
 706   return;
 707
 708 /* At this point the start of an exponent has been found */
 709
 710 exp1:
 711   while (w > 0 && *p == ' ')
 712     {
 713       w--;
 714       p++;
 715     }
 716
 717   switch (*p)
 718     {
 719     case '-':
 720       exponent_sign = -1;
 721       /* Fall through */
 722
 723     case '+':
 724       p++;
 725       w--;
 726       break;
 727     }
 728
 729   if (w == 0)
 730     goto bad_float;
 731
 732 /* At this point a digit string is required.  We calculate the value
 733  * of the exponent in order to take account of the scale factor and
 734  * the d parameter before explict conversion takes place. */
 735
 736 exp2:
 737   if (!isdigit (*p))
 738     goto bad_float;
 739
 740   exponent = *p - '0';
 741   p++;
 742   w--;
 743
 744   while (w > 0 && isdigit (*p))
 745     {
 746       exponent = 10 * exponent + *p - '0';
 747       if (exponent > 999999)
 748         goto bad_float;
 749
 750       p++;
 751       w--;
 752     }
 753
 754   /* Only allow trailing blanks */
 755
 756   while (w > 0)
 757     {
 758       if (*p != ' ')
 759         goto bad_float;
 760       p++;
 761       w--;
 762     }
 763
 764   exponent = exponent * exponent_sign;
 765
 766 done:
 767   if (!seen_dp)
 768     exponent -= f->u.real.d;
 769
 770   /* The number is syntactically correct and ready for conversion.
 771    * The only thing that can go wrong at this point is overflow or
 772    * underflow. */
 773
 774   convert_precision_real (dest, val_sign, buffer, length, exponent);
 775
 776   if (buffer != scratch)
 777      free_mem (buffer);
 778
 779   return;
 780 }
 781
 782
 783 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
 784  * and never look at it. */
 785
 786 void
 787 read_x (fnode * f)
 788 {
 789   int n;
 790
 791   n = f->u.n;
 792   read_block (&n);
 793 }