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