libgfortran/io/inquire.c

   1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009, 2010
   2    Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   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 3, or (at your option)
  10 any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26
  27 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
  28
  29 #include "io.h"
  30 #include "unix.h"
  31
  32
  33 static const char undefined[] = "UNDEFINED";
  34
  35
  36 /* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */
  37
  38 static void
  39 inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
  40 {
  41   const char *p;
  42   GFC_INTEGER_4 cf = iqp->common.flags;
  43
  44   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
  45     {
  46       *iqp->exist = (iqp->common.unit >= 0
  47                      && iqp->common.unit <= GFC_INTEGER_4_HUGE);
  48
  49       if ((cf & IOPARM_INQUIRE_HAS_FILE) == 0)
  50         {
  51           if (!(*iqp->exist))
  52             *iqp->common.iostat = LIBERROR_BAD_UNIT;
  53           *iqp->exist = *iqp->exist
  54                         && (*iqp->common.iostat != LIBERROR_BAD_UNIT);
  55         }
  56     }
  57
  58   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
  59     *iqp->opened = (u != NULL);
  60
  61   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
  62     *iqp->number = (u != NULL) ? u->unit_number : -1;
  63
  64   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
  65     *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
  66
  67   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
  68       && u != NULL && u->flags.status != STATUS_SCRATCH)
  69     fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
  70
  71   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
  72     {
  73       if (u == NULL)
  74         p = undefined;
  75       else
  76         switch (u->flags.access)
  77           {
  78           case ACCESS_SEQUENTIAL:
  79             p = "SEQUENTIAL";
  80             break;
  81           case ACCESS_DIRECT:
  82             p = "DIRECT";
  83             break;
  84           case ACCESS_STREAM:
  85             p = "STREAM";
  86             break;
  87           default:
  88             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
  89           }
  90
  91       cf_strcpy (iqp->access, iqp->access_len, p);
  92     }
  93
  94   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
  95     {
  96       if (u == NULL)
  97         p = inquire_sequential (NULL, 0);
  98       else
  99         switch (u->flags.access)
 100           {
 101           case ACCESS_DIRECT:
 102           case ACCESS_STREAM:
 103             p = "NO";
 104             break;
 105           case ACCESS_SEQUENTIAL:
 106             p = "YES";
 107             break;
 108           default:
 109             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
 110           }
 111
 112       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
 113     }
 114
 115   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
 116     {
 117       if (u == NULL)
 118         p = inquire_direct (NULL, 0);
 119       else
 120         switch (u->flags.access)
 121           {
 122           case ACCESS_SEQUENTIAL:
 123           case ACCESS_STREAM:
 124             p = "NO";
 125             break;
 126           case ACCESS_DIRECT:
 127             p = "YES";
 128             break;
 129           default:
 130             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
 131           }
 132
 133       cf_strcpy (iqp->direct, iqp->direct_len, p);
 134     }
 135
 136   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
 137     {
 138       if (u == NULL)
 139         p = undefined;
 140       else
 141         switch (u->flags.form)
 142           {
 143           case FORM_FORMATTED:
 144             p = "FORMATTED";
 145             break;
 146           case FORM_UNFORMATTED:
 147             p = "UNFORMATTED";
 148             break;
 149           default:
 150             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
 151           }
 152
 153       cf_strcpy (iqp->form, iqp->form_len, p);
 154     }
 155
 156   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
 157     {
 158       if (u == NULL)
 159         p = inquire_formatted (NULL, 0);
 160       else
 161         switch (u->flags.form)
 162           {
 163           case FORM_FORMATTED:
 164             p = "YES";
 165             break;
 166           case FORM_UNFORMATTED:
 167             p = "NO";
 168             break;
 169           default:
 170             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
 171           }
 172
 173       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
 174     }
 175
 176   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
 177     {
 178       if (u == NULL)
 179         p = inquire_unformatted (NULL, 0);
 180       else
 181         switch (u->flags.form)
 182           {
 183           case FORM_FORMATTED:
 184             p = "NO";
 185             break;
 186           case FORM_UNFORMATTED:
 187             p = "YES";
 188             break;
 189           default:
 190             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
 191           }
 192
 193       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
 194     }
 195
 196   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
 197     *iqp->recl_out = (u != NULL) ? u->recl : 0;
 198
 199   if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
 200     *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0;
 201
 202   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
 203     {
 204       /* This only makes sense in the context of DIRECT access.  */
 205       if (u != NULL && u->flags.access == ACCESS_DIRECT)
 206         *iqp->nextrec = u->last_record + 1;
 207       else
 208         *iqp->nextrec = 0;
 209     }
 210
 211   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
 212     {
 213       if (u == NULL || u->flags.form != FORM_FORMATTED)
 214         p = undefined;
 215       else
 216         switch (u->flags.blank)
 217           {
 218           case BLANK_NULL:
 219             p = "NULL";
 220             break;
 221           case BLANK_ZERO:
 222             p = "ZERO";
 223             break;
 224           default:
 225             internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
 226           }
 227
 228       cf_strcpy (iqp->blank, iqp->blank_len, p);
 229     }
 230
 231   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 232     {
 233       if (u == NULL || u->flags.form != FORM_FORMATTED)
 234         p = undefined;
 235       else
 236         switch (u->flags.pad)
 237           {
 238           case PAD_YES:
 239             p = "YES";
 240             break;
 241           case PAD_NO:
 242             p = "NO";
 243             break;
 244           default:
 245             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
 246           }
 247
 248       cf_strcpy (iqp->pad, iqp->pad_len, p);
 249     }
 250
 251   if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
 252     {
 253       GFC_INTEGER_4 cf2 = iqp->flags2;
 254
 255       if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
 256         *iqp->pending = 0;
 257
 258       if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
 259         *iqp->id = 0;
 260
 261       if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 262         {
 263           if (u == NULL || u->flags.form != FORM_FORMATTED)
 264             p = undefined;
 265           else
 266             switch (u->flags.encoding)
 267               {
 268               case ENCODING_DEFAULT:
 269                 p = "UNKNOWN";
 270                 break;
 271               case ENCODING_UTF8:
 272                 p = "UTF-8";
 273                 break;
 274               default:
 275                 internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
 276               }
 277
 278           cf_strcpy (iqp->encoding, iqp->encoding_len, p);
 279         }
 280
 281       if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
 282         {
 283           if (u == NULL || u->flags.form != FORM_FORMATTED)
 284             p = undefined;
 285           else
 286             switch (u->flags.decimal)
 287               {
 288               case DECIMAL_POINT:
 289                 p = "POINT";
 290                 break;
 291               case DECIMAL_COMMA:
 292                 p = "COMMA";
 293                 break;
 294               default:
 295                 internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
 296               }
 297
 298           cf_strcpy (iqp->decimal, iqp->decimal_len, p);
 299         }
 300
 301       if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
 302         {
 303           if (u == NULL)
 304             p = undefined;
 305           else
 306             switch (u->flags.async)
 307             {
 308               case ASYNC_YES:
 309                 p = "YES";
 310                 break;
 311               case ASYNC_NO:
 312                 p = "NO";
 313                 break;
 314               default:
 315                 internal_error (&iqp->common, "inquire_via_unit(): Bad async");
 316             }
 317
 318           cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
 319         }
 320
 321       if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
 322         {
 323           if (u == NULL)
 324             p = undefined;
 325           else
 326             switch (u->flags.sign)
 327             {
 328               case SIGN_PROCDEFINED:
 329                 p = "PROCESSOR_DEFINED";
 330                 break;
 331               case SIGN_SUPPRESS:
 332                 p = "SUPPRESS";
 333                 break;
 334               case SIGN_PLUS:
 335                 p = "PLUS";
 336                 break;
 337               default:
 338                 internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
 339             }
 340
 341           cf_strcpy (iqp->sign, iqp->sign_len, p);
 342         }
 343
 344       if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
 345         {
 346           if (u == NULL)
 347             p = undefined;
 348           else
 349             switch (u->flags.round)
 350             {
 351               case ROUND_UP:
 352                 p = "UP";
 353                 break;
 354               case ROUND_DOWN:
 355                 p = "DOWN";
 356                 break;
 357               case ROUND_ZERO:
 358                 p = "ZERO";
 359                 break;
 360               case ROUND_NEAREST:
 361                 p = "NEAREST";
 362                 break;
 363               case ROUND_COMPATIBLE:
 364                 p = "COMPATIBLE";
 365                 break;
 366               case ROUND_PROCDEFINED:
 367                 p = "PROCESSOR_DEFINED";
 368                 break;
 369               default:
 370                 internal_error (&iqp->common, "inquire_via_unit(): Bad round");
 371             }
 372
 373           cf_strcpy (iqp->round, iqp->round_len, p);
 374         }
 375
 376       if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
 377         {
 378           if (u == NULL)
 379             *iqp->size = -1;
 380           else
 381             *iqp->size = file_size (u->file, (gfc_charlen_type) u->file_len);
 382         }
 383     }
 384
 385   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
 386     {
 387       if (u == NULL || u->flags.access == ACCESS_DIRECT)
 388         p = undefined;
 389       else
 390         switch (u->flags.position)
 391           {
 392              case POSITION_REWIND:
 393                p = "REWIND";
 394                break;
 395              case POSITION_APPEND:
 396                p = "APPEND";
 397                break;
 398              case POSITION_ASIS:
 399                p = "ASIS";
 400                break;
 401              default:
 402                /* if not direct access, it must be
 403                   either REWIND, APPEND, or ASIS.
 404                   ASIS seems to be the best default */
 405                p = "ASIS";
 406                break;
 407           }
 408       cf_strcpy (iqp->position, iqp->position_len, p);
 409     }
 410
 411   if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
 412     {
 413       if (u == NULL)
 414         p = undefined;
 415       else
 416         switch (u->flags.action)
 417           {
 418           case ACTION_READ:
 419             p = "READ";
 420             break;
 421           case ACTION_WRITE:
 422             p = "WRITE";
 423             break;
 424           case ACTION_READWRITE:
 425             p = "READWRITE";
 426             break;
 427           default:
 428             internal_error (&iqp->common, "inquire_via_unit(): Bad action");
 429           }
 430
 431       cf_strcpy (iqp->action, iqp->action_len, p);
 432     }
 433
 434   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
 435     {
 436       p = (u == NULL) ? inquire_read (NULL, 0) :
 437         inquire_read (u->file, u->file_len);
 438
 439       cf_strcpy (iqp->read, iqp->read_len, p);
 440     }
 441
 442   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
 443     {
 444       p = (u == NULL) ? inquire_write (NULL, 0) :
 445         inquire_write (u->file, u->file_len);
 446
 447       cf_strcpy (iqp->write, iqp->write_len, p);
 448     }
 449
 450   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
 451     {
 452       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
 453         inquire_readwrite (u->file, u->file_len);
 454
 455       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
 456     }
 457
 458   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
 459     {
 460       if (u == NULL || u->flags.form != FORM_FORMATTED)
 461         p = undefined;
 462       else
 463         switch (u->flags.delim)
 464           {
 465           case DELIM_NONE:
 466             p = "NONE";
 467             break;
 468           case DELIM_QUOTE:
 469             p = "QUOTE";
 470             break;
 471           case DELIM_APOSTROPHE:
 472             p = "APOSTROPHE";
 473             break;
 474           default:
 475             internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
 476           }
 477
 478       cf_strcpy (iqp->delim, iqp->delim_len, p);
 479     }
 480
 481   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 482     {
 483       if (u == NULL || u->flags.form != FORM_FORMATTED)
 484         p = undefined;
 485       else
 486         switch (u->flags.pad)
 487           {
 488           case PAD_NO:
 489             p = "NO";
 490             break;
 491           case PAD_YES:
 492             p = "YES";
 493             break;
 494           default:
 495             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
 496           }
 497
 498       cf_strcpy (iqp->pad, iqp->pad_len, p);
 499     }
 500
 501   if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
 502     {
 503       if (u == NULL)
 504         p = undefined;
 505       else
 506         switch (u->flags.convert)
 507           {
 508             /*  big_endian is 0 for little-endian, 1 for big-endian.  */
 509           case GFC_CONVERT_NATIVE:
 510             p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
 511             break;
 512
 513           case GFC_CONVERT_SWAP:
 514             p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
 515             break;
 516
 517           default:
 518             internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
 519           }
 520
 521       cf_strcpy (iqp->convert, iqp->convert_len, p);
 522     }
 523 }
 524
 525
 526 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
 527  * only used if the filename is *not* connected to a unit number. */
 528
 529 static void
 530 inquire_via_filename (st_parameter_inquire *iqp)
 531 {
 532   const char *p;
 533   GFC_INTEGER_4 cf = iqp->common.flags;
 534
 535   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
 536     *iqp->exist = file_exists (iqp->file, iqp->file_len);
 537
 538   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
 539     *iqp->opened = 0;
 540
 541   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
 542     *iqp->number = -1;
 543
 544   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
 545     *iqp->named = 1;
 546
 547   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
 548     fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
 549
 550   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 551     cf_strcpy (iqp->access, iqp->access_len, undefined);
 552
 553   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
 554     {
 555       p = "UNKNOWN";
 556       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
 557     }
 558
 559   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
 560     {
 561       p = "UNKNOWN";
 562       cf_strcpy (iqp->direct, iqp->direct_len, p);
 563     }
 564
 565   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
 566     cf_strcpy (iqp->form, iqp->form_len, undefined);
 567
 568   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
 569     {
 570       p = "UNKNOWN";
 571       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
 572     }
 573
 574   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
 575     {
 576       p = "UNKNOWN";
 577       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
 578     }
 579
 580   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
 581     *iqp->recl_out = 0;
 582
 583   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
 584     *iqp->nextrec = 0;
 585
 586   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
 587     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
 588
 589   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 590     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 591
 592   if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
 593     {
 594       GFC_INTEGER_4 cf2 = iqp->flags2;
 595
 596       if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 597         cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
 598
 599       if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
 600         cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 601
 602       if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
 603         cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
 604
 605       if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
 606         cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 607
 608       if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
 609         cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 610
 611       if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 612         cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
 613
 614       if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
 615         *iqp->size = file_size (iqp->file, iqp->file_len);
 616     }
 617
 618   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
 619     cf_strcpy (iqp->position, iqp->position_len, undefined);
 620
 621   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 622     cf_strcpy (iqp->access, iqp->access_len, undefined);
 623
 624   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
 625     {
 626       p = inquire_read (iqp->file, iqp->file_len);
 627       cf_strcpy (iqp->read, iqp->read_len, p);
 628     }
 629
 630   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
 631     {
 632       p = inquire_write (iqp->file, iqp->file_len);
 633       cf_strcpy (iqp->write, iqp->write_len, p);
 634     }
 635
 636   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
 637     {
 638       p = inquire_read (iqp->file, iqp->file_len);
 639       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
 640     }
 641 }
 642
 643
 644 /* Library entry point for the INQUIRE statement (non-IOLENGTH
 645    form).  */
 646
 647 extern void st_inquire (st_parameter_inquire *);
 648 export_proto(st_inquire);
 649
 650 void
 651 st_inquire (st_parameter_inquire *iqp)
 652 {
 653   gfc_unit *u;
 654
 655   library_start (&iqp->common);
 656
 657   if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
 658     {
 659       u = find_unit (iqp->common.unit);
 660       inquire_via_unit (iqp, u);
 661     }
 662   else
 663     {
 664       u = find_file (iqp->file, iqp->file_len);
 665       if (u == NULL)
 666         inquire_via_filename (iqp);
 667       else
 668         inquire_via_unit (iqp, u);
 669     }
 670   if (u != NULL)
 671     unlock_unit (u);
 672
 673   library_end ();
 674 }