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