libgfortran/io/read.c

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