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