libgfortran/io/inquire.c

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