old-autovect-branch/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   int n;
  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 != 0 && errno != EINVAL)
 179     {
 180       generate_error (&dtp->common, ERROR_READ_VALUE,
 181                       "Range error during floating point read");
 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, ERROR_READ_VALUE,
 229                       "Bad value on logical read");
 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, ERROR_READ_VALUE,
 399                   "Bad value during integer read");
 400   return;
 401
 402  overflow:
 403   generate_error (&dtp->common, ERROR_READ_OVERFLOW,
 404                   "Value overflowed during integer read");
 405   return;
 406 }
 407
 408
 409 /* read_radix()-- This function reads values for non-decimal radixes.
 410  * The difference here is that we treat the values here as unsigned
 411  * values for the purposes of overflow.  If minus sign is present and
 412  * the top bit is set, the value will be incorrect. */
 413
 414 void
 415 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 416             int radix)
 417 {
 418   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
 419   GFC_INTEGER_LARGEST v;
 420   int w, negative;
 421   char c, *p;
 422
 423   w = f->u.w;
 424   p = read_block (dtp, &w);
 425   if (p == NULL)
 426     return;
 427
 428   p = eat_leading_spaces (&w, p);
 429   if (w == 0)
 430     {
 431       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
 432       return;
 433     }
 434
 435   maxv = max_value (length, 0);
 436   maxv_r = maxv / radix;
 437
 438   negative = 0;
 439   value = 0;
 440
 441   switch (*p)
 442     {
 443     case '-':
 444       negative = 1;
 445       /* Fall through */
 446
 447     case '+':
 448       p++;
 449       if (--w == 0)
 450         goto bad;
 451       /* Fall through */
 452
 453     default:
 454       break;
 455     }
 456
 457   /* At this point we have a digit-string */
 458   value = 0;
 459
 460   for (;;)
 461     {
 462       c = next_char (dtp, &p, &w);
 463       if (c == '\0')
 464         break;
 465       if (c == ' ')
 466         {
 467           if (dtp->u.p.blank_status == BLANK_NULL) continue;
 468           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
 469         }
 470
 471       switch (radix)
 472         {
 473         case 2:
 474           if (c < '0' || c > '1')
 475             goto bad;
 476           break;
 477
 478         case 8:
 479           if (c < '0' || c > '7')
 480             goto bad;
 481           break;
 482
 483         case 16:
 484           switch (c)
 485             {
 486             case '0':
 487             case '1':
 488             case '2':
 489             case '3':
 490             case '4':
 491             case '5':
 492             case '6':
 493             case '7':
 494             case '8':
 495             case '9':
 496               break;
 497
 498             case 'a':
 499             case 'b':
 500             case 'c':
 501             case 'd':
 502             case 'e':
 503             case 'f':
 504               c = c - 'a' + '9' + 1;
 505               break;
 506
 507             case 'A':
 508             case 'B':
 509             case 'C':
 510             case 'D':
 511             case 'E':
 512             case 'F':
 513               c = c - 'A' + '9' + 1;
 514               break;
 515
 516             default:
 517               goto bad;
 518             }
 519
 520           break;
 521         }
 522
 523       if (value > maxv_r)
 524         goto overflow;
 525
 526       c -= '0';
 527       value = radix * value;
 528
 529       if (maxv - c < value)
 530         goto overflow;
 531       value += c;
 532     }
 533
 534   v = value;
 535   if (negative)
 536     v = -v;
 537
 538   set_integer (dest, v, length);
 539   return;
 540
 541  bad:
 542   generate_error (&dtp->common, ERROR_READ_VALUE,
 543                   "Bad value during integer read");
 544   return;
 545
 546  overflow:
 547   generate_error (&dtp->common, ERROR_READ_OVERFLOW,
 548                   "Value overflowed during integer read");
 549   return;
 550 }
 551
 552
 553 /* read_f()-- Read a floating point number with F-style editing, which
 554    is what all of the other floating point descriptors behave as.  The
 555    tricky part is that optional spaces are allowed after an E or D,
 556    and the implicit decimal point if a decimal point is not present in
 557    the input.  */
 558
 559 void
 560 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 561 {
 562   int w, seen_dp, exponent;
 563   int exponent_sign, val_sign;
 564   int ndigits;
 565   int edigits;
 566   int i;
 567   char *p, *buffer;
 568   char *digits;
 569   char scratch[SCRATCH_SIZE];
 570
 571   val_sign = 1;
 572   seen_dp = 0;
 573   w = f->u.w;
 574   p = read_block (dtp, &w);
 575   if (p == NULL)
 576     return;
 577
 578   p = eat_leading_spaces (&w, p);
 579   if (w == 0)
 580     goto zero;
 581
 582   /* Optional sign */
 583
 584   if (*p == '-' || *p == '+')
 585     {
 586       if (*p == '-')
 587         val_sign = -1;
 588       p++;
 589       w--;
 590     }
 591
 592   exponent_sign = 1;
 593   p = eat_leading_spaces (&w, p);
 594   if (w == 0)
 595     goto zero;
 596
 597   /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
 598      is required at this point */
 599
 600   if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
 601       && *p != 'e' && *p != 'E')
 602     goto bad_float;
 603
 604   /* Remember the position of the first digit.  */
 605   digits = p;
 606   ndigits = 0;
 607
 608   /* Scan through the string to find the exponent.  */
 609   while (w > 0)
 610     {
 611       switch (*p)
 612         {
 613         case '.':
 614           if (seen_dp)
 615             goto bad_float;
 616           seen_dp = 1;
 617           /* Fall through */
 618
 619         case '0':
 620         case '1':
 621         case '2':
 622         case '3':
 623         case '4':
 624         case '5':
 625         case '6':
 626         case '7':
 627         case '8':
 628         case '9':
 629         case ' ':
 630           ndigits++;
 631           p++;
 632           w--;
 633           break;
 634
 635         case '-':
 636           exponent_sign = -1;
 637           /* Fall through */
 638
 639         case '+':
 640           p++;
 641           w--;
 642           goto exp2;
 643
 644         case 'd':
 645         case 'e':
 646         case 'D':
 647         case 'E':
 648           p++;
 649           w--;
 650           goto exp1;
 651
 652         default:
 653           goto bad_float;
 654         }
 655     }
 656
 657   /* No exponent has been seen, so we use the current scale factor */
 658   exponent = -dtp->u.p.scale_factor;
 659   goto done;
 660
 661  bad_float:
 662   generate_error (&dtp->common, ERROR_READ_VALUE,
 663                   "Bad value during floating point read");
 664   return;
 665
 666   /* The value read is zero */
 667  zero:
 668   switch (length)
 669     {
 670       case 4:
 671         *((GFC_REAL_4 *) dest) = 0;
 672         break;
 673
 674       case 8:
 675         *((GFC_REAL_8 *) dest) = 0;
 676         break;
 677
 678 #ifdef HAVE_GFC_REAL_10
 679       case 10:
 680         *((GFC_REAL_10 *) dest) = 0;
 681         break;
 682 #endif
 683
 684 #ifdef HAVE_GFC_REAL_16
 685       case 16:
 686         *((GFC_REAL_16 *) dest) = 0;
 687         break;
 688 #endif
 689
 690       default:
 691         internal_error (&dtp->common, "Unsupported real kind during IO");
 692     }
 693   return;
 694
 695   /* At this point the start of an exponent has been found */
 696  exp1:
 697   while (w > 0 && *p == ' ')
 698     {
 699       w--;
 700       p++;
 701     }
 702
 703   switch (*p)
 704     {
 705     case '-':
 706       exponent_sign = -1;
 707       /* Fall through */
 708
 709     case '+':
 710       p++;
 711       w--;
 712       break;
 713     }
 714
 715   if (w == 0)
 716     goto bad_float;
 717
 718   /* At this point a digit string is required.  We calculate the value
 719      of the exponent in order to take account of the scale factor and
 720      the d parameter before explict conversion takes place. */
 721  exp2:
 722   if (!isdigit (*p))
 723     goto bad_float;
 724
 725   exponent = *p - '0';
 726   p++;
 727   w--;
 728
 729   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
 730     {
 731       while (w > 0 && isdigit (*p))
 732         {
 733           exponent = 10 * exponent + *p - '0';
 734           p++;
 735           w--;
 736         }
 737
 738       /* Only allow trailing blanks */
 739
 740       while (w > 0)
 741         {
 742           if (*p != ' ')
 743           goto bad_float;
 744           p++;
 745           w--;
 746         }
 747     }
 748   else  /* BZ or BN status is enabled */
 749     {
 750       while (w > 0)
 751         {
 752           if (*p == ' ')
 753             {
 754               if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
 755               if (dtp->u.p.blank_status == BLANK_NULL)
 756                 {
 757                   p++;
 758                   w--;
 759                   continue;
 760                 }
 761             }
 762           else if (!isdigit (*p))
 763             goto bad_float;
 764
 765           exponent = 10 * exponent + *p - '0';
 766           p++;
 767           w--;
 768         }
 769     }
 770
 771   exponent = exponent * exponent_sign;
 772
 773  done:
 774   /* Use the precision specified in the format if no decimal point has been
 775      seen.  */
 776   if (!seen_dp)
 777     exponent -= f->u.real.d;
 778
 779   if (exponent > 0)
 780     {
 781       edigits = 2;
 782       i = exponent;
 783     }
 784   else
 785     {
 786       edigits = 3;
 787       i = -exponent;
 788     }
 789
 790   while (i >= 10)
 791     {
 792       i /= 10;
 793       edigits++;
 794     }
 795
 796   i = ndigits + edigits + 1;
 797   if (val_sign < 0)
 798     i++;
 799
 800   if (i < SCRATCH_SIZE)
 801     buffer = scratch;
 802   else
 803     buffer = get_mem (i);
 804
 805   /* Reformat the string into a temporary buffer.  As we're using atof it's
 806      easiest to just leave the decimal point in place.  */
 807   p = buffer;
 808   if (val_sign < 0)
 809     *(p++) = '-';
 810   for (; ndigits > 0; ndigits--)
 811     {
 812       if (*digits == ' ')
 813         {
 814           if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
 815           if (dtp->u.p.blank_status == BLANK_NULL)
 816             {
 817               digits++;
 818               continue;
 819             }
 820         }
 821       *p = *digits;
 822       p++;
 823       digits++;
 824     }
 825   *(p++) = 'e';
 826   sprintf (p, "%d", exponent);
 827
 828   /* Do the actual conversion.  */
 829   convert_real (dtp, dest, buffer, length);
 830
 831   if (buffer != scratch)
 832      free_mem (buffer);
 833
 834   return;
 835 }
 836
 837
 838 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
 839  * and never look at it. */
 840
 841 void
 842 read_x (st_parameter_dt *dtp, int n)
 843 {
 844   if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
 845       && dtp->u.p.current_unit->bytes_left < n)
 846     n = dtp->u.p.current_unit->bytes_left;
 847
 848   dtp->u.p.sf_read_comma = 0;
 849   if (n > 0)
 850     read_block (dtp, &n);
 851   dtp->u.p.sf_read_comma = 1;
 852
 853 }