libgfortran/io/read.c

   1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    F2003 I/O support contributed by Jerry DeLisle
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "io.h"
  32 #include <string.h>
  33 #include <errno.h>
  34 #include <ctype.h>
  35 #include <stdlib.h>
  36
  37 /* read.c -- Deal with formatted reads */
  38
  39 /* set_integer()-- All of the integer assignments come here to
  40  * actually place the value into memory.  */
  41
  42 void
  43 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
  44 {
  45   switch (length)
  46     {
  47 #ifdef HAVE_GFC_INTEGER_16
  48     case 16:
  49       {
  50         GFC_INTEGER_16 tmp = value;
  51         memcpy (dest, (void *) &tmp, length);
  52       }
  53       break;
  54 #endif
  55     case 8:
  56       {
  57         GFC_INTEGER_8 tmp = value;
  58         memcpy (dest, (void *) &tmp, length);
  59       }
  60       break;
  61     case 4:
  62       {
  63         GFC_INTEGER_4 tmp = value;
  64         memcpy (dest, (void *) &tmp, length);
  65       }
  66       break;
  67     case 2:
  68       {
  69         GFC_INTEGER_2 tmp = value;
  70         memcpy (dest, (void *) &tmp, length);
  71       }
  72       break;
  73     case 1:
  74       {
  75         GFC_INTEGER_1 tmp = value;
  76         memcpy (dest, (void *) &tmp, length);
  77       }
  78       break;
  79     default:
  80       internal_error (NULL, "Bad integer kind");
  81     }
  82 }
  83
  84
  85 /* max_value()-- Given a length (kind), return the maximum signed or
  86  * unsigned value */
  87
  88 GFC_UINTEGER_LARGEST
  89 max_value (int length, int signed_flag)
  90 {
  91   GFC_UINTEGER_LARGEST value;
  92 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
  93   int n;
  94 #endif
  95
  96   switch (length)
  97     {
  98 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
  99     case 16:
 100     case 10:
 101       value = 1;
 102       for (n = 1; n < 4 * length; n++)
 103         value = (value << 2) + 3;
 104       if (! signed_flag)
 105         value = 2*value+1;
 106       break;
 107 #endif
 108     case 8:
 109       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
 110       break;
 111     case 4:
 112       value = signed_flag ? 0x7fffffff : 0xffffffff;
 113       break;
 114     case 2:
 115       value = signed_flag ? 0x7fff : 0xffff;
 116       break;
 117     case 1:
 118       value = signed_flag ? 0x7f : 0xff;
 119       break;
 120     default:
 121       internal_error (NULL, "Bad integer kind");
 122     }
 123
 124   return value;
 125 }
 126
 127
 128 /* convert_real()-- Convert a character representation of a floating
 129  * point number to the machine number.  Returns nonzero if there is a
 130  * range problem during conversion.  TODO: handle not-a-numbers and
 131  * infinities.  */
 132
 133 int
 134 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
 135 {
 136   errno = 0;
 137
 138   switch (length)
 139     {
 140     case 4:
 141       {
 142         GFC_REAL_4 tmp =
 143 #if defined(HAVE_STRTOF)
 144           strtof (buffer, NULL);
 145 #else
 146           (GFC_REAL_4) strtod (buffer, NULL);
 147 #endif
 148         memcpy (dest, (void *) &tmp, length);
 149       }
 150       break;
 151     case 8:
 152       {
 153         GFC_REAL_8 tmp = strtod (buffer, NULL);
 154         memcpy (dest, (void *) &tmp, length);
 155       }
 156       break;
 157 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
 158     case 10:
 159       {
 160         GFC_REAL_10 tmp = strtold (buffer, NULL);
 161         memcpy (dest, (void *) &tmp, length);
 162       }
 163       break;
 164 #endif
 165 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
 166     case 16:
 167       {
 168         GFC_REAL_16 tmp = strtold (buffer, NULL);
 169         memcpy (dest, (void *) &tmp, length);
 170       }
 171       break;
 172 #endif
 173     default:
 174       internal_error (&dtp->common, "Unsupported real kind during IO");
 175     }
 176
 177   if (errno == EINVAL)
 178     {
 179       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 180                       "Error during floating point read");
 181       next_record (dtp, 1);
 182       return 1;
 183     }
 184
 185   return 0;
 186 }
 187
 188
 189 /* read_l()-- Read a logical value */
 190
 191 void
 192 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 193 {
 194   char *p;
 195   int w;
 196
 197   w = f->u.w;
 198   p = read_block (dtp, &w);
 199   if (p == NULL)
 200     return;
 201
 202   while (*p == ' ')
 203     {
 204       if (--w == 0)
 205         goto bad;
 206       p++;
 207     }
 208
 209   if (*p == '.')
 210     {
 211       if (--w == 0)
 212         goto bad;
 213       p++;
 214     }
 215
 216   switch (*p)
 217     {
 218     case 't':
 219     case 'T':
 220       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
 221       break;
 222     case 'f':
 223     case 'F':
 224       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 225       break;
 226     default:
 227     bad:
 228       generate_error (&dtp->common, LIBERROR_READ_VALUE,
 229                       "Bad value on logical read");
 230       next_record (dtp, 1);
 231       break;
 232     }
 233 }
 234
 235
 236 /* read_a()-- Read a character record.  This one is pretty easy. */
 237
 238 void
 239 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 240 {
 241   char *source;
 242   int w, m, n;
 243
 244   w = f->u.w;
 245   if (w == -1) /* '(A)' edit descriptor  */
 246     w = length;
 247
 248   dtp->u.p.sf_read_comma = 0;
 249   source = read_block (dtp, &w);
 250   dtp->u.p.sf_read_comma =
 251     dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
 252   if (source == NULL)
 253     return;
 254   if (w > length)
 255      source += (w - length);
 256
 257   m = (w > length) ? length : w;
 258   memcpy (p, source, m);
 259
 260   n = length - w;
 261   if (n > 0)
 262     memset (p + m, ' ', n);
 263 }
 264
 265
 266 /* eat_leading_spaces()-- Given a character pointer and a width,
 267  * ignore the leading spaces.  */
 268
 269 static char *
 270 eat_leading_spaces (int *width, char *p)
 271 {
 272   for (;;)
 273     {
 274       if (*width == 0 || *p != ' ')
 275         break;
 276
 277       (*width)--;
 278       p++;
 279     }
 280
 281   return p;
 282 }
 283
 284
 285 static char
 286 next_char (st_parameter_dt *dtp, char **p, int *w)
 287 {
 288   char c, *q;
 289
 290   if (*w == 0)
 291     return '\0';
 292
 293   q = *p;
 294   c = *q++;
 295   *p = q;
 296
 297   (*w)--;
 298
 299   if (c != ' ')
 300     return c;
 301   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
 302     return ' ';  /* return a blank to signal a null */
 303
 304   /* At this point, the rest of the field has to be trailing blanks */
 305
 306   while (*w > 0)
 307     {
 308       if (*q++ != ' ')
 309         return '?';
 310       (*w)--;
 311     }
 312
 313   *p = q;
 314   return '\0';
 315 }
 316
 317
 318 /* read_decimal()-- Read a decimal integer value.  The values here are
 319  * signed values. */
 320
 321 void
 322 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 323 {
 324   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
 325   GFC_INTEGER_LARGEST v;
 326   int w, negative;
 327   char c, *p;
 328
 329   w = f->u.w;
 330   p = read_block (dtp, &w);
 331   if (p == NULL)
 332     return;
 333
 334   p = eat_leading_spaces (&w, p);
 335   if (w == 0)
 336     {
 337       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 338       return;
 339     }
 340
 341   maxv = max_value (length, 1);
 342   maxv_10 = maxv / 10;
 343
 344   negative = 0;
 345   value = 0;
 346
 347   switch (*p)
 348     {
 349     case '-':
 350       negative = 1;
 351       /* Fall through */
 352
 353     case '+':
 354       p++;
 355       if (--w == 0)
 356         goto bad;
 357       /* Fall through */
 358
 359     default:
 360       break;
 361     }
 362
 363   /* At this point we have a digit-string */
 364   value = 0;
 365
 366   for (;;)
 367     {
 368       c = next_char (dtp, &p, &w);
 369       if (c == '\0')
 370         break;
 371
 372       if (c == ' ')
 373         {
 374           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 375           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 376         }
 377
 378       if (c < '0' || c > '9')
 379         goto bad;
 380
 381       if (value > maxv_10)
 382         goto overflow;
 383
 384       c -= '0';
 385       value = 10 * value;
 386
 387       if (value > maxv - c)
 388         goto overflow;
 389       value += c;
 390     }
 391
 392   v = value;
 393   if (negative)
 394     v = -v;
 395
 396   set_integer (dest, v, length);
 397   return;
 398
 399  bad:
 400   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 401                   "Bad value during integer read");
 402   next_record (dtp, 1);
 403   return;
 404
 405  overflow:
 406   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 407                   "Value overflowed during integer read");
 408   next_record (dtp, 1);
 409   return;
 410 }
 411
 412
 413 /* read_radix()-- This function reads values for non-decimal radixes.
 414  * The difference here is that we treat the values here as unsigned
 415  * values for the purposes of overflow.  If minus sign is present and
 416  * the top bit is set, the value will be incorrect. */
 417
 418 void
 419 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 420             int radix)
 421 {
 422   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 423   GFC_INTEGER_LARGEST v;
 424   int w, negative;
 425   char c, *p;
 426
 427   w = f->u.w;
 428   p = read_block (dtp, &w);
 429   if (p == NULL)
 430     return;
 431
 432   p = eat_leading_spaces (&w, p);
 433   if (w == 0)
 434     {
 435       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 436       return;
 437     }
 438
 439   maxv = max_value (length, 0);
 440   maxv_r = maxv / radix;
 441
 442   negative = 0;
 443   value = 0;
 444
 445   switch (*p)
 446     {
 447     case '-':
 448       negative = 1;
 449       /* Fall through */
 450
 451     case '+':
 452       p++;
 453       if (--w == 0)
 454         goto bad;
 455       /* Fall through */
 456
 457     default:
 458       break;
 459     }
 460
 461   /* At this point we have a digit-string */
 462   value = 0;
 463
 464   for (;;)
 465     {
 466       c = next_char (dtp, &p, &w);
 467       if (c == '\0')
 468         break;
 469       if (c == ' ')
 470         {
 471           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 472           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 473         }
 474
 475       switch (radix)
 476         {
 477         case 2:
 478           if (c < '0' || c > '1')
 479             goto bad;
 480           break;
 481
 482         case 8:
 483           if (c < '0' || c > '7')
 484             goto bad;
 485           break;
 486
 487         case 16:
 488           switch (c)
 489             {
 490             case '0':
 491             case '1':
 492             case '2':
 493             case '3':
 494             case '4':
 495             case '5':
 496             case '6':
 497             case '7':
 498             case '8':
 499             case '9':
 500               break;
 501
 502             case 'a':
 503             case 'b':
 504             case 'c':
 505             case 'd':
 506             case 'e':
 507             case 'f':
 508               c = c - 'a' + '9' + 1;
 509               break;
 510
 511             case 'A':
 512             case 'B':
 513             case 'C':
 514             case 'D':
 515             case 'E':
 516             case 'F':
 517               c = c - 'A' + '9' + 1;
 518               break;
 519
 520             default:
 521               goto bad;
 522             }
 523
 524           break;
 525         }
 526
 527       if (value > maxv_r)
 528         goto overflow;
 529
 530       c -= '0';
 531       value = radix * value;
 532
 533       if (maxv - c < value)
 534         goto overflow;
 535       value += c;
 536     }
 537
 538   v = value;
 539   if (negative)
 540     v = -v;
 541
 542   set_integer (dest, v, length);
 543   return;
 544
 545  bad:
 546   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 547                   "Bad value during integer read");
 548   next_record (dtp, 1);
 549   return;
 550
 551  overflow:
 552   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
 553                   "Value overflowed during integer read");
 554   next_record (dtp, 1);
 555   return;
 556 }
 557
 558
 559 /* read_f()-- Read a floating point number with F-style editing, which
 560    is what all of the other floating point descriptors behave as.  The
 561    tricky part is that optional spaces are allowed after an E or D,
 562    and the implicit decimal point if a decimal point is not present in
 563    the input.  */
 564
 565 void
 566 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 567 {
 568   int w, seen_dp, exponent;
 569   int exponent_sign, val_sign;
 570   int ndigits;
 571   int edigits;
 572   int i;
 573   char *p, *buffer;
 574   char *digits;
 575   char scratch[SCRATCH_SIZE];
 576
 577   val_sign = 1;
 578   seen_dp = 0;
 579   w = f->u.w;
 580   p = read_block (dtp, &w);
 581   if (p == NULL)
 582     return;
 583
 584   p = eat_leading_spaces (&w, p);
 585   if (w == 0)
 586     goto zero;
 587
 588   /* Optional sign */
 589
 590   if (*p == '-' || *p == '+')
 591     {
 592       if (*p == '-')
 593         val_sign = -1;
 594       p++;
 595       w--;
 596     }
 597
 598   exponent_sign = 1;
 599   p = eat_leading_spaces (&w, p);
 600   if (w == 0)
 601     goto zero;
 602
 603   /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
 604      is required at this point */
 605
 606   if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
 607       && *p != 'e' && *p != 'E')
 608     goto bad_float;
 609
 610   /* Remember the position of the first digit.  */
 611   digits = p;
 612   ndigits = 0;
 613
 614   /* Scan through the string to find the exponent.  */
 615   while (w > 0)
 616     {
 617       switch (*p)
 618         {
 619         case ',':
 620           if (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ',')
 621             *p = '.';
 622           /* Fall through */
 623         case '.':
 624           if (seen_dp)
 625             goto bad_float;
 626           seen_dp = 1;
 627           /* Fall through */
 628
 629         case '0':
 630         case '1':
 631         case '2':
 632         case '3':
 633         case '4':
 634         case '5':
 635         case '6':
 636         case '7':
 637         case '8':
 638         case '9':
 639         case ' ':
 640           ndigits++;
 641           p++;
 642           w--;
 643           break;
 644
 645         case '-':
 646           exponent_sign = -1;
 647           /* Fall through */
 648
 649         case '+':
 650           p++;
 651           w--;
 652           goto exp2;
 653
 654         case 'd':
 655         case 'e':
 656         case 'D':
 657         case 'E':
 658           p++;
 659           w--;
 660           goto exp1;
 661
 662         default:
 663           goto bad_float;
 664         }
 665     }
 666
 667   /* No exponent has been seen, so we use the current scale factor */
 668   exponent = -dtp->u.p.scale_factor;
 669   goto done;
 670
 671  bad_float:
 672   generate_error (&dtp->common, LIBERROR_READ_VALUE,
 673                   "Bad value during floating point read");
 674   next_record (dtp, 1);
 675   return;
 676
 677   /* The value read is zero */
 678  zero:
 679   switch (length)
 680     {
 681       case 4:
 682         *((GFC_REAL_4 *) dest) = 0;
 683         break;
 684
 685       case 8:
 686         *((GFC_REAL_8 *) dest) = 0;
 687         break;
 688
 689 #ifdef HAVE_GFC_REAL_10
 690       case 10:
 691         *((GFC_REAL_10 *) dest) = 0;
 692         break;
 693 #endif
 694
 695 #ifdef HAVE_GFC_REAL_16
 696       case 16:
 697         *((GFC_REAL_16 *) dest) = 0;
 698         break;
 699 #endif
 700
 701       default:
 702         internal_error (&dtp->common, "Unsupported real kind during IO");
 703     }
 704   return;
 705
 706   /* At this point the start of an exponent has been found */
 707  exp1:
 708   while (w > 0 && *p == ' ')
 709     {
 710       w--;
 711       p++;
 712     }
 713
 714   switch (*p)
 715     {
 716     case '-':
 717       exponent_sign = -1;
 718       /* Fall through */
 719
 720     case '+':
 721       p++;
 722       w--;
 723       break;
 724     }
 725
 726   if (w == 0)
 727     goto bad_float;
 728
 729   /* At this point a digit string is required.  We calculate the value
 730      of the exponent in order to take account of the scale factor and
 731      the d parameter before explict conversion takes place. */
 732  exp2:
 733   if (!isdigit (*p))
 734     goto bad_float;
 735
 736   exponent = *p - '0';
 737   p++;
 738   w--;
 739
 740   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
 741     {
 742       while (w > 0 && isdigit (*p))
 743         {
 744           exponent = 10 * exponent + *p - '0';
 745           p++;
 746           w--;
 747         }
 748
 749       /* Only allow trailing blanks */
 750
 751       while (w > 0)
 752         {
 753           if (*p != ' ')
 754           goto bad_float;
 755           p++;
 756           w--;
 757         }
 758     }
 759   else  /* BZ or BN status is enabled */
 760     {
 761       while (w > 0)
 762         {
 763           if (*p == ' ')
 764             {
 765               if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
 766               if (dtp->u.p.blank_status == BLANK_NULL)
 767                 {
 768                   p++;
 769                   w--;
 770                   continue;
 771                 }
 772             }
 773           else if (!isdigit (*p))
 774             goto bad_float;
 775
 776           exponent = 10 * exponent + *p - '0';
 777           p++;
 778           w--;
 779         }
 780     }
 781
 782   exponent = exponent * exponent_sign;
 783
 784  done:
 785   /* Use the precision specified in the format if no decimal point has been
 786      seen.  */
 787   if (!seen_dp)
 788     exponent -= f->u.real.d;
 789
 790   if (exponent > 0)
 791     {
 792       edigits = 2;
 793       i = exponent;
 794     }
 795   else
 796     {
 797       edigits = 3;
 798       i = -exponent;
 799     }
 800
 801   while (i >= 10)
 802     {
 803       i /= 10;
 804       edigits++;
 805     }
 806
 807   i = ndigits + edigits + 1;
 808   if (val_sign < 0)
 809     i++;
 810
 811   if (i < SCRATCH_SIZE)
 812     buffer = scratch;
 813   else
 814     buffer = get_mem (i);
 815
 816   /* Reformat the string into a temporary buffer.  As we're using atof it's
 817      easiest to just leave the decimal point in place.  */
 818   p = buffer;
 819   if (val_sign < 0)
 820     *(p++) = '-';
 821   for (; ndigits > 0; ndigits--)
 822     {
 823       if (*digits == ' ')
 824         {
 825           if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
 826           if (dtp->u.p.blank_status == BLANK_NULL)
 827             {
 828               digits++;
 829               continue;
 830             }
 831         }
 832       *p = *digits;
 833       p++;
 834       digits++;
 835     }
 836   *(p++) = 'e';
 837   sprintf (p, "%d", exponent);
 838
 839   /* Do the actual conversion.  */
 840   convert_real (dtp, dest, buffer, length);
 841
 842   if (buffer != scratch)
 843      free_mem (buffer);
 844
 845   return;
 846 }
 847
 848
 849 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
 850  * and never look at it. */
 851
 852 void
 853 read_x (st_parameter_dt *dtp, int n)
 854 {
 855   if (!is_stream_io (dtp))
 856     {
 857       if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp))
 858           && dtp->u.p.current_unit->bytes_left < n)
 859         n = dtp->u.p.current_unit->bytes_left;
 860
 861       dtp->u.p.sf_read_comma = 0;
 862       if (n > 0)
 863         read_sf (dtp, &n, 1);
 864       dtp->u.p.sf_read_comma = 1;
 865     }
 866   else
 867     dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
 868 }