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