libgfortran/io/read.c

   1 /* Copyright (C) 2002, 2003, 2005 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
  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       {
  53         GFC_INTEGER_16 tmp = value;
  54         memcpy (dest, (void *) &tmp, length);
  55       }
  56       break;
  57 #endif
  58     case 8:
  59       {
  60         GFC_INTEGER_8 tmp = value;
  61         memcpy (dest, (void *) &tmp, length);
  62       }
  63       break;
  64     case 4:
  65       {
  66         GFC_INTEGER_4 tmp = value;
  67         memcpy (dest, (void *) &tmp, length);
  68       }
  69       break;
  70     case 2:
  71       {
  72         GFC_INTEGER_2 tmp = value;
  73         memcpy (dest, (void *) &tmp, length);
  74       }
  75       break;
  76     case 1:
  77       {
  78         GFC_INTEGER_1 tmp = value;
  79         memcpy (dest, (void *) &tmp, length);
  80       }
  81       break;
  82     default:
  83       internal_error (NULL, "Bad integer kind");
  84     }
  85 }
  86
  87
  88 /* max_value()-- Given a length (kind), return the maximum signed or
  89  * unsigned value */
  90
  91 GFC_UINTEGER_LARGEST
  92 max_value (int length, int signed_flag)
  93 {
  94   GFC_UINTEGER_LARGEST value;
  95 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
  96   int n;
  97 #endif
  98
  99   switch (length)
 100     {
 101 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
 102     case 16:
 103     case 10:
 104       value = 1;
 105       for (n = 1; n < 4 * length; n++)
 106         value = (value << 2) + 3;
 107       if (! signed_flag)
 108         value = 2*value+1;
 109       break;
 110 #endif
 111     case 8:
 112       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
 113       break;
 114     case 4:
 115       value = signed_flag ? 0x7fffffff : 0xffffffff;
 116       break;
 117     case 2:
 118       value = signed_flag ? 0x7fff : 0xffff;
 119       break;
 120     case 1:
 121       value = signed_flag ? 0x7f : 0xff;
 122       break;
 123     default:
 124       internal_error (NULL, "Bad integer kind");
 125     }
 126
 127   return value;
 128 }
 129
 130
 131 /* convert_real()-- Convert a character representation of a floating
 132  * point number to the machine number.  Returns nonzero if there is a
 133  * range problem during conversion.  TODO: handle not-a-numbers and
 134  * infinities.  */
 135
 136 int
 137 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
 138 {
 139   errno = 0;
 140
 141   switch (length)
 142     {
 143     case 4:
 144       {
 145         GFC_REAL_4 tmp =
 146 #if defined(HAVE_STRTOF)
 147           strtof (buffer, NULL);
 148 #else
 149           (GFC_REAL_4) strtod (buffer, NULL);
 150 #endif
 151         memcpy (dest, (void *) &tmp, length);
 152       }
 153       break;
 154     case 8:
 155       {
 156         GFC_REAL_8 tmp = strtod (buffer, NULL);
 157         memcpy (dest, (void *) &tmp, length);
 158       }
 159       break;
 160 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
 161     case 10:
 162       {
 163         GFC_REAL_10 tmp = strtold (buffer, NULL);
 164         memcpy (dest, (void *) &tmp, length);
 165       }
 166       break;
 167 #endif
 168 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
 169     case 16:
 170       {
 171         GFC_REAL_16 tmp = strtold (buffer, NULL);
 172         memcpy (dest, (void *) &tmp, length);
 173       }
 174       break;
 175 #endif
 176     default:
 177       internal_error (&dtp->common, "Unsupported real kind during IO");
 178     }
 179
 180   if (errno != 0 && errno != EINVAL)
 181     {
 182       generate_error (&dtp->common, ERROR_READ_VALUE,
 183                       "Range error during floating point read");
 184       return 1;
 185     }
 186
 187   return 0;
 188 }
 189
 190
 191 /* read_l()-- Read a logical value */
 192
 193 void
 194 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 195 {
 196   char *p;
 197   int w;
 198
 199   w = f->u.w;
 200   p = read_block (dtp, &w);
 201   if (p == NULL)
 202     return;
 203
 204   while (*p == ' ')
 205     {
 206       if (--w == 0)
 207         goto bad;
 208       p++;
 209     }
 210
 211   if (*p == '.')
 212     {
 213       if (--w == 0)
 214         goto bad;
 215       p++;
 216     }
 217
 218   switch (*p)
 219     {
 220     case 't':
 221     case 'T':
 222       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
 223       break;
 224     case 'f':
 225     case 'F':
 226       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 227       break;
 228     default:
 229     bad:
 230       generate_error (&dtp->common, ERROR_READ_VALUE,
 231                       "Bad value on logical read");
 232       break;
 233     }
 234 }
 235
 236
 237 /* read_a()-- Read a character record.  This one is pretty easy. */
 238
 239 void
 240 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 241 {
 242   char *source;
 243   int w, m, n;
 244
 245   w = f->u.w;
 246   if (w == -1) /* '(A)' edit descriptor  */
 247     w = length;
 248
 249   dtp->u.p.sf_read_comma = 0;
 250   source = read_block (dtp, &w);
 251   dtp->u.p.sf_read_comma = 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, ERROR_READ_VALUE,
 401                   "Bad value during integer read");
 402   return;
 403
 404  overflow:
 405   generate_error (&dtp->common, ERROR_READ_OVERFLOW,
 406                   "Value overflowed during integer read");
 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, ERROR_READ_VALUE,
 545                   "Bad value during integer read");
 546   return;
 547
 548  overflow:
 549   generate_error (&dtp->common, ERROR_READ_OVERFLOW,
 550                   "Value overflowed during integer read");
 551   return;
 552 }
 553
 554
 555 /* read_f()-- Read a floating point number with F-style editing, which
 556    is what all of the other floating point descriptors behave as.  The
 557    tricky part is that optional spaces are allowed after an E or D,
 558    and the implicit decimal point if a decimal point is not present in
 559    the input.  */
 560
 561 void
 562 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 563 {
 564   int w, seen_dp, exponent;
 565   int exponent_sign, val_sign;
 566   int ndigits;
 567   int edigits;
 568   int i;
 569   char *p, *buffer;
 570   char *digits;
 571   char scratch[SCRATCH_SIZE];
 572
 573   val_sign = 1;
 574   seen_dp = 0;
 575   w = f->u.w;
 576   p = read_block (dtp, &w);
 577   if (p == NULL)
 578     return;
 579
 580   p = eat_leading_spaces (&w, p);
 581   if (w == 0)
 582     goto zero;
 583
 584   /* Optional sign */
 585
 586   if (*p == '-' || *p == '+')
 587     {
 588       if (*p == '-')
 589         val_sign = -1;
 590       p++;
 591       w--;
 592     }
 593
 594   exponent_sign = 1;
 595   p = eat_leading_spaces (&w, p);
 596   if (w == 0)
 597     goto zero;
 598
 599   /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
 600      is required at this point */
 601
 602   if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
 603       && *p != 'e' && *p != 'E')
 604     goto bad_float;
 605
 606   /* Remember the position of the first digit.  */
 607   digits = p;
 608   ndigits = 0;
 609
 610   /* Scan through the string to find the exponent.  */
 611   while (w > 0)
 612     {
 613       switch (*p)
 614         {
 615         case '.':
 616           if (seen_dp)
 617             goto bad_float;
 618           seen_dp = 1;
 619           /* Fall through */
 620
 621         case '0':
 622         case '1':
 623         case '2':
 624         case '3':
 625         case '4':
 626         case '5':
 627         case '6':
 628         case '7':
 629         case '8':
 630         case '9':
 631         case ' ':
 632           ndigits++;
 633           p++;
 634           w--;
 635           break;
 636
 637         case '-':
 638           exponent_sign = -1;
 639           /* Fall through */
 640
 641         case '+':
 642           p++;
 643           w--;
 644           goto exp2;
 645
 646         case 'd':
 647         case 'e':
 648         case 'D':
 649         case 'E':
 650           p++;
 651           w--;
 652           goto exp1;
 653
 654         default:
 655           goto bad_float;
 656         }
 657     }
 658
 659   /* No exponent has been seen, so we use the current scale factor */
 660   exponent = -dtp->u.p.scale_factor;
 661   goto done;
 662
 663  bad_float:
 664   generate_error (&dtp->common, ERROR_READ_VALUE,
 665                   "Bad value during floating point read");
 666   return;
 667
 668   /* The value read is zero */
 669  zero:
 670   switch (length)
 671     {
 672       case 4:
 673         *((GFC_REAL_4 *) dest) = 0;
 674         break;
 675
 676       case 8:
 677         *((GFC_REAL_8 *) dest) = 0;
 678         break;
 679
 680 #ifdef HAVE_GFC_REAL_10
 681       case 10:
 682         *((GFC_REAL_10 *) dest) = 0;
 683         break;
 684 #endif
 685
 686 #ifdef HAVE_GFC_REAL_16
 687       case 16:
 688         *((GFC_REAL_16 *) dest) = 0;
 689         break;
 690 #endif
 691
 692       default:
 693         internal_error (&dtp->common, "Unsupported real kind during IO");
 694     }
 695   return;
 696
 697   /* At this point the start of an exponent has been found */
 698  exp1:
 699   while (w > 0 && *p == ' ')
 700     {
 701       w--;
 702       p++;
 703     }
 704
 705   switch (*p)
 706     {
 707     case '-':
 708       exponent_sign = -1;
 709       /* Fall through */
 710
 711     case '+':
 712       p++;
 713       w--;
 714       break;
 715     }
 716
 717   if (w == 0)
 718     goto bad_float;
 719
 720   /* At this point a digit string is required.  We calculate the value
 721      of the exponent in order to take account of the scale factor and
 722      the d parameter before explict conversion takes place. */
 723  exp2:
 724   if (!isdigit (*p))
 725     goto bad_float;
 726
 727   exponent = *p - '0';
 728   p++;
 729   w--;
 730
 731   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
 732     {
 733       while (w > 0 && isdigit (*p))
 734         {
 735           exponent = 10 * exponent + *p - '0';
 736           p++;
 737           w--;
 738         }
 739
 740       /* Only allow trailing blanks */
 741
 742       while (w > 0)
 743         {
 744           if (*p != ' ')
 745           goto bad_float;
 746           p++;
 747           w--;
 748         }
 749     }
 750   else  /* BZ or BN status is enabled */
 751     {
 752       while (w > 0)
 753         {
 754           if (*p == ' ')
 755             {
 756               if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
 757               if (dtp->u.p.blank_status == BLANK_NULL)
 758                 {
 759                   p++;
 760                   w--;
 761                   continue;
 762                 }
 763             }
 764           else if (!isdigit (*p))
 765             goto bad_float;
 766
 767           exponent = 10 * exponent + *p - '0';
 768           p++;
 769           w--;
 770         }
 771     }
 772
 773   exponent = exponent * exponent_sign;
 774
 775  done:
 776   /* Use the precision specified in the format if no decimal point has been
 777      seen.  */
 778   if (!seen_dp)
 779     exponent -= f->u.real.d;
 780
 781   if (exponent > 0)
 782     {
 783       edigits = 2;
 784       i = exponent;
 785     }
 786   else
 787     {
 788       edigits = 3;
 789       i = -exponent;
 790     }
 791
 792   while (i >= 10)
 793     {
 794       i /= 10;
 795       edigits++;
 796     }
 797
 798   i = ndigits + edigits + 1;
 799   if (val_sign < 0)
 800     i++;
 801
 802   if (i < SCRATCH_SIZE)
 803     buffer = scratch;
 804   else
 805     buffer = get_mem (i);
 806
 807   /* Reformat the string into a temporary buffer.  As we're using atof it's
 808      easiest to just leave the decimal point in place.  */
 809   p = buffer;
 810   if (val_sign < 0)
 811     *(p++) = '-';
 812   for (; ndigits > 0; ndigits--)
 813     {
 814       if (*digits == ' ')
 815         {
 816           if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
 817           if (dtp->u.p.blank_status == BLANK_NULL)
 818             {
 819               digits++;
 820               continue;
 821             }
 822         }
 823       *p = *digits;
 824       p++;
 825       digits++;
 826     }
 827   *(p++) = 'e';
 828   sprintf (p, "%d", exponent);
 829
 830   /* Do the actual conversion.  */
 831   convert_real (dtp, dest, buffer, length);
 832
 833   if (buffer != scratch)
 834      free_mem (buffer);
 835
 836   return;
 837 }
 838
 839
 840 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
 841  * and never look at it. */
 842
 843 void
 844 read_x (st_parameter_dt *dtp, int n)
 845 {
 846   if (!is_stream_io (dtp))
 847     {
 848       if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
 849           && dtp->u.p.current_unit->bytes_left < n)
 850         n = dtp->u.p.current_unit->bytes_left;
 851
 852       dtp->u.p.sf_read_comma = 0;
 853       if (n > 0)
 854         read_sf (dtp, &n, 1);
 855       dtp->u.p.sf_read_comma = 1;
 856     }
 857   else
 858     dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
 859 }