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             case 'f':
 530               c = c - 'a' + '9' + 1;
 531               break;
 532
 533             case 'A':
 534             case 'B':
 535             case 'C':
 536             case 'D':
 537             case 'E':
 538             case 'F':
 539               c = c - 'A' + '9' + 1;
 540               break;
 541
 542             default:
 543               goto bad;
 544             }
 545
 546           break;
 547         }
 548
 549       if (value > maxv_r)
 550         goto overflow;
 551
 552       c -= '0';
 553       value = radix * value;
 554
 555       if (maxv - c < value)
 556         goto overflow;
 557       value += c;
 558     }
 559
 560   v = (signed int) value;
 561   if (negative)
 562     v = -v;
 563
 564   set_integer (dest, v, length);
 565   return;
 566
 567 bad:
 568   generate_error (ERROR_READ_VALUE, "Bad value during integer read");
 569   return;
 570
 571 overflow:
 572   generate_error (ERROR_READ_OVERFLOW,
 573                   "Value overflowed during integer read");
 574   return;
 575 }
 576
 577
 578 /* read_f()-- Read a floating point number with F-style editing, which
 579  * is what all of the other floating point descriptors behave as.  The
 580  * tricky part is that optional spaces are allowed after an E or D,
 581  * and the implicit decimal point if a decimal point is not present in
 582  * the input. */
 583
 584 void
 585 read_f (fnode * f, char *dest, int length)
 586 {
 587   int w, seen_dp, exponent;
 588   int exponent_sign, val_sign;
 589   char *p, *buffer, *n;
 590
 591   val_sign = 0;
 592   seen_dp = 0;
 593   w = f->u.w;
 594   p = read_block (&w);
 595   if (p == NULL)
 596     return;
 597
 598   p = eat_leading_spaces (&w, p);
 599   if (w == 0)
 600     {
 601       switch (length)
 602         {
 603         case 4:
 604           *((float *) dest) = 0.0;
 605           break;
 606
 607         case 8:
 608           *((double *) dest) = 0.0;
 609           break;
 610         }
 611
 612       return;
 613     }
 614
 615   if (w + 2 < SCRATCH_SIZE)
 616     buffer = scratch;
 617   else
 618     buffer = get_mem (w + 2);
 619
 620   memset(buffer, 0, w + 2);
 621
 622   n = buffer;
 623
 624   /* Optional sign */
 625
 626   if (*p == '-' || *p == '+')
 627     {
 628       if (*p == '-')
 629         val_sign = 1;
 630       p++;
 631
 632       if (--w == 0)
 633         goto bad_float;
 634     }
 635
 636   exponent_sign = 1;
 637
 638   /* A digit (or a '.') is required at this point */
 639
 640   if (!isdigit (*p) && *p != '.')
 641     goto bad_float;
 642
 643   while (w > 0)
 644     {
 645       switch (*p)
 646         {
 647         case '0':
 648         case '1':
 649         case '2':
 650         case '3':
 651         case '4':
 652         case '5':
 653         case '6':
 654         case '7':
 655         case '8':
 656         case '9':
 657           *n++ = *p++;
 658           w--;
 659           break;
 660
 661         case '.':
 662           if (seen_dp)
 663             goto bad_float;
 664           seen_dp = 1;
 665
 666           *n++ = *p++;
 667           w--;
 668           break;
 669
 670         case ' ':
 671           if (g.blank_status == BLANK_ZERO)
 672             *n++ = '0';
 673           p++;
 674           w--;
 675           break;
 676
 677         case '-':
 678           exponent_sign = -1;
 679           /* Fall through */
 680
 681         case '+':
 682           p++;
 683           w--;
 684           goto exp2;
 685
 686         case 'd':
 687         case 'e':
 688         case 'D':
 689         case 'E':
 690           p++;
 691           w--;
 692           goto exp1;
 693
 694         default:
 695           goto bad_float;
 696         }
 697     }
 698
 699 /* No exponent has been seen, so we use the current scale factor */
 700
 701   exponent = -g.scale_factor;
 702   goto done;
 703
 704 bad_float:
 705   generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
 706   if (buffer != scratch)
 707      free_mem (buffer);
 708   return;
 709
 710 /* At this point the start of an exponent has been found */
 711
 712 exp1:
 713   while (w > 0 && *p == ' ')
 714     {
 715       w--;
 716       p++;
 717     }
 718
 719   switch (*p)
 720     {
 721     case '-':
 722       exponent_sign = -1;
 723       /* Fall through */
 724
 725     case '+':
 726       p++;
 727       w--;
 728       break;
 729     }
 730
 731   if (w == 0)
 732     goto bad_float;
 733
 734 /* At this point a digit string is required.  We calculate the value
 735  * of the exponent in order to take account of the scale factor and
 736  * the d parameter before explict conversion takes place. */
 737
 738 exp2:
 739   if (!isdigit (*p))
 740     goto bad_float;
 741
 742   exponent = *p - '0';
 743   p++;
 744   w--;
 745
 746   while (w > 0 && isdigit (*p))
 747     {
 748       exponent = 10 * exponent + *p - '0';
 749       if (exponent > 999999)
 750         goto bad_float;
 751
 752       p++;
 753       w--;
 754     }
 755
 756   /* Only allow trailing blanks */
 757
 758   while (w > 0)
 759     {
 760       if (*p != ' ')
 761         goto bad_float;
 762       p++;
 763       w--;
 764     }
 765
 766   exponent = exponent * exponent_sign;
 767
 768 done:
 769   if (!seen_dp)
 770     exponent -= f->u.real.d;
 771
 772   /* The number is syntactically correct and ready for conversion.
 773    * The only thing that can go wrong at this point is overflow or
 774    * underflow. */
 775
 776   convert_precision_real (dest, val_sign, buffer, length, exponent);
 777
 778   if (buffer != scratch)
 779      free_mem (buffer);
 780
 781   return;
 782 }
 783
 784
 785 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
 786  * and never look at it. */
 787
 788 void
 789 read_x (fnode * f)
 790 {
 791   int n;
 792
 793   n = f->u.n;
 794   read_block (&n);
 795 }