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 ((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 ((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   GFC_INTEGER_4 cf2 = iqp->flags2;
 526
 527   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
 528     *iqp->exist = file_exists (iqp->file, iqp->file_len);
 529
 530   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
 531     *iqp->opened = 0;
 532
 533   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
 534     *iqp->number = -1;
 535
 536   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
 537     *iqp->named = 1;
 538
 539   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
 540     fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
 541
 542   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 543     cf_strcpy (iqp->access, iqp->access_len, undefined);
 544
 545   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
 546     {
 547       p = "UNKNOWN";
 548       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
 549     }
 550
 551   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
 552     {
 553       p = "UNKNOWN";
 554       cf_strcpy (iqp->direct, iqp->direct_len, p);
 555     }
 556
 557   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
 558     cf_strcpy (iqp->form, iqp->form_len, undefined);
 559
 560   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
 561     {
 562       p = "UNKNOWN";
 563       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
 564     }
 565
 566   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
 567     {
 568       p = "UNKNOWN";
 569       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
 570     }
 571
 572   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
 573     *iqp->recl_out = 0;
 574
 575   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
 576     *iqp->nextrec = 0;
 577
 578   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
 579     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
 580
 581   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 582     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 583
 584   if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 585     cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
 586
 587   if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
 588     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 589
 590   if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
 591     cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
 592
 593   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
 594     cf_strcpy (iqp->position, iqp->position_len, undefined);
 595
 596   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 597     cf_strcpy (iqp->access, iqp->access_len, undefined);
 598
 599   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
 600     {
 601       p = inquire_read (iqp->file, iqp->file_len);
 602       cf_strcpy (iqp->read, iqp->read_len, p);
 603     }
 604
 605   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
 606     {
 607       p = inquire_write (iqp->file, iqp->file_len);
 608       cf_strcpy (iqp->write, iqp->write_len, p);
 609     }
 610
 611   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
 612     {
 613       p = inquire_read (iqp->file, iqp->file_len);
 614       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
 615     }
 616
 617   if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
 618     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 619
 620   if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
 621     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 622
 623   if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 624     cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
 625 }
 626
 627
 628 /* Library entry point for the INQUIRE statement (non-IOLENGTH
 629    form).  */
 630
 631 extern void st_inquire (st_parameter_inquire *);
 632 export_proto(st_inquire);
 633
 634 void
 635 st_inquire (st_parameter_inquire *iqp)
 636 {
 637   gfc_unit *u;
 638
 639   library_start (&iqp->common);
 640
 641   if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
 642     {
 643       u = find_unit (iqp->common.unit);
 644       inquire_via_unit (iqp, u);
 645     }
 646   else
 647     {
 648       u = find_file (iqp->file, iqp->file_len);
 649       if (u == NULL)
 650         inquire_via_filename (iqp);
 651       else
 652         inquire_via_unit (iqp, u);
 653     }
 654   if (u != NULL)
 655     unlock_unit (u);
 656
 657   library_end ();
 658 }