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           /* TODO: Enable UTF-8 case here when implemented.
 272           case ENCODING_UTF8:
 273             p = "UTF-8";
 274             break; */
 275           default:
 276             internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
 277           }
 278
 279       cf_strcpy (iqp->encoding, iqp->encoding_len, p);
 280     }
 281
 282   if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
 283     {
 284       if (u == NULL || u->flags.form != FORM_FORMATTED)
 285         p = undefined;
 286       else
 287         switch (u->flags.decimal)
 288           {
 289           case DECIMAL_POINT:
 290             p = "POINT";
 291             break;
 292           case DECIMAL_COMMA:
 293             p = "COMMA";
 294             break;
 295           default:
 296             internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
 297           }
 298
 299       cf_strcpy (iqp->decimal, iqp->decimal_len, p);
 300     }
 301
 302   if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
 303     {
 304       if (u == NULL)
 305         p = undefined;
 306       else
 307         switch (u->flags.async)
 308           {
 309           case ASYNC_YES:
 310             p = "YES";
 311             break;
 312           case ASYNC_NO:
 313             p = "NO";
 314             break;
 315           default:
 316             internal_error (&iqp->common, "inquire_via_unit(): Bad async");
 317           }
 318
 319       cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
 320     }
 321
 322   if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
 323     {
 324       if (u == NULL)
 325         p = undefined;
 326       else
 327         switch (u->flags.sign)
 328           {
 329           case SIGN_PROCDEFINED:
 330             p = "PROCESSOR_DEFINED";
 331             break;
 332           case SIGN_SUPPRESS:
 333             p = "SUPPRESS";
 334             break;
 335           case SIGN_PLUS:
 336             p = "PLUS";
 337             break;
 338           default:
 339             internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
 340           }
 341
 342       cf_strcpy (iqp->sign, iqp->sign_len, p);
 343     }
 344
 345   if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
 346     {
 347       if (u == NULL)
 348         p = undefined;
 349       else
 350         switch (u->flags.round)
 351           {
 352           case ROUND_UP:
 353             p = "UP";
 354             break;
 355           case ROUND_DOWN:
 356             p = "DOWN";
 357             break;
 358           case ROUND_ZERO:
 359             p = "ZERO";
 360             break;
 361           case ROUND_NEAREST:
 362             p = "NEAREST";
 363             break;
 364           case ROUND_COMPATIBLE:
 365             p = "COMPATIBLE";
 366             break;
 367           case ROUND_PROCDEFINED:
 368             p = "PROCESSOR_DEFINED";
 369             break;
 370           default:
 371             internal_error (&iqp->common, "inquire_via_unit(): Bad round");
 372           }
 373
 374       cf_strcpy (iqp->round, iqp->round_len, p);
 375     }
 376
 377   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
 378     {
 379       if (u == NULL || u->flags.access == ACCESS_DIRECT)
 380         p = undefined;
 381       else
 382         switch (u->flags.position)
 383           {
 384              case POSITION_REWIND:
 385                p = "REWIND";
 386                break;
 387              case POSITION_APPEND:
 388                p = "APPEND";
 389                break;
 390              case POSITION_ASIS:
 391                p = "ASIS";
 392                break;
 393              default:
 394                /* if not direct access, it must be
 395                   either REWIND, APPEND, or ASIS.
 396                   ASIS seems to be the best default */
 397                p = "ASIS";
 398                break;
 399           }
 400       cf_strcpy (iqp->position, iqp->position_len, p);
 401     }
 402
 403   if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
 404     {
 405       if (u == NULL)
 406         p = undefined;
 407       else
 408         switch (u->flags.action)
 409           {
 410           case ACTION_READ:
 411             p = "READ";
 412             break;
 413           case ACTION_WRITE:
 414             p = "WRITE";
 415             break;
 416           case ACTION_READWRITE:
 417             p = "READWRITE";
 418             break;
 419           default:
 420             internal_error (&iqp->common, "inquire_via_unit(): Bad action");
 421           }
 422
 423       cf_strcpy (iqp->action, iqp->action_len, p);
 424     }
 425
 426   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
 427     {
 428       p = (u == NULL) ? inquire_read (NULL, 0) :
 429         inquire_read (u->file, u->file_len);
 430
 431       cf_strcpy (iqp->read, iqp->read_len, p);
 432     }
 433
 434   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
 435     {
 436       p = (u == NULL) ? inquire_write (NULL, 0) :
 437         inquire_write (u->file, u->file_len);
 438
 439       cf_strcpy (iqp->write, iqp->write_len, p);
 440     }
 441
 442   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
 443     {
 444       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
 445         inquire_readwrite (u->file, u->file_len);
 446
 447       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
 448     }
 449
 450   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
 451     {
 452       if (u == NULL || u->flags.form != FORM_FORMATTED)
 453         p = undefined;
 454       else
 455         switch (u->flags.delim)
 456           {
 457           case DELIM_NONE:
 458             p = "NONE";
 459             break;
 460           case DELIM_QUOTE:
 461             p = "QUOTE";
 462             break;
 463           case DELIM_APOSTROPHE:
 464             p = "APOSTROPHE";
 465             break;
 466           default:
 467             internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
 468           }
 469
 470       cf_strcpy (iqp->delim, iqp->delim_len, p);
 471     }
 472
 473   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 474     {
 475       if (u == NULL || u->flags.form != FORM_FORMATTED)
 476         p = undefined;
 477       else
 478         switch (u->flags.pad)
 479           {
 480           case PAD_NO:
 481             p = "NO";
 482             break;
 483           case PAD_YES:
 484             p = "YES";
 485             break;
 486           default:
 487             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
 488           }
 489
 490       cf_strcpy (iqp->pad, iqp->pad_len, p);
 491     }
 492
 493   if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
 494     {
 495       if (u == NULL)
 496         p = undefined;
 497       else
 498         switch (u->flags.convert)
 499           {
 500             /*  l8_to_l4_offset is 0 for little-endian, 1 for big-endian.  */
 501           case GFC_CONVERT_NATIVE:
 502             p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
 503             break;
 504
 505           case GFC_CONVERT_SWAP:
 506             p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
 507             break;
 508
 509           default:
 510             internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
 511           }
 512
 513       cf_strcpy (iqp->convert, iqp->convert_len, p);
 514     }
 515 }
 516
 517
 518 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
 519  * only used if the filename is *not* connected to a unit number. */
 520
 521 static void
 522 inquire_via_filename (st_parameter_inquire *iqp)
 523 {
 524   const char *p;
 525   GFC_INTEGER_4 cf = iqp->common.flags;
 526   GFC_INTEGER_4 cf2 = iqp->flags2;
 527
 528   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
 529     *iqp->exist = file_exists (iqp->file, iqp->file_len);
 530
 531   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
 532     *iqp->opened = 0;
 533
 534   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
 535     *iqp->number = -1;
 536
 537   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
 538     *iqp->named = 1;
 539
 540   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
 541     fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
 542
 543   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 544     cf_strcpy (iqp->access, iqp->access_len, undefined);
 545
 546   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
 547     {
 548       p = "UNKNOWN";
 549       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
 550     }
 551
 552   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
 553     {
 554       p = "UNKNOWN";
 555       cf_strcpy (iqp->direct, iqp->direct_len, p);
 556     }
 557
 558   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
 559     cf_strcpy (iqp->form, iqp->form_len, undefined);
 560
 561   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
 562     {
 563       p = "UNKNOWN";
 564       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
 565     }
 566
 567   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
 568     {
 569       p = "UNKNOWN";
 570       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
 571     }
 572
 573   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
 574     *iqp->recl_out = 0;
 575
 576   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
 577     *iqp->nextrec = 0;
 578
 579   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
 580     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
 581
 582   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 583     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 584
 585   if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 586     cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
 587
 588   if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
 589     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 590
 591   if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
 592     cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
 593
 594   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
 595     cf_strcpy (iqp->position, iqp->position_len, undefined);
 596
 597   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 598     cf_strcpy (iqp->access, iqp->access_len, undefined);
 599
 600   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
 601     {
 602       p = inquire_read (iqp->file, iqp->file_len);
 603       cf_strcpy (iqp->read, iqp->read_len, p);
 604     }
 605
 606   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
 607     {
 608       p = inquire_write (iqp->file, iqp->file_len);
 609       cf_strcpy (iqp->write, iqp->write_len, p);
 610     }
 611
 612   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
 613     {
 614       p = inquire_read (iqp->file, iqp->file_len);
 615       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
 616     }
 617
 618   if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
 619     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 620
 621   if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
 622     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 623
 624   if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 625     cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
 626 }
 627
 628
 629 /* Library entry point for the INQUIRE statement (non-IOLENGTH
 630    form).  */
 631
 632 extern void st_inquire (st_parameter_inquire *);
 633 export_proto(st_inquire);
 634
 635 void
 636 st_inquire (st_parameter_inquire *iqp)
 637 {
 638   gfc_unit *u;
 639
 640   library_start (&iqp->common);
 641
 642   if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
 643     {
 644       u = find_unit (iqp->common.unit);
 645       inquire_via_unit (iqp, u);
 646     }
 647   else
 648     {
 649       u = find_file (iqp->file, iqp->file_len);
 650       if (u == NULL)
 651         inquire_via_filename (iqp);
 652       else
 653         inquire_via_unit (iqp, u);
 654     }
 655   if (u != NULL)
 656     unlock_unit (u);
 657
 658   library_end ();
 659 }