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