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     *iqp->exist = iqp->common.unit >= 0;
  49
  50   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
  51     *iqp->opened = (u != NULL);
  52
  53   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
  54     *iqp->number = (u != NULL) ? u->unit_number : -1;
  55
  56   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
  57     *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
  58
  59   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
  60       && u != NULL && u->flags.status != STATUS_SCRATCH)
  61     fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
  62
  63   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
  64     {
  65       if (u == NULL)
  66         p = undefined;
  67       else
  68         switch (u->flags.access)
  69           {
  70           case ACCESS_SEQUENTIAL:
  71             p = "SEQUENTIAL";
  72             break;
  73           case ACCESS_DIRECT:
  74             p = "DIRECT";
  75             break;
  76           case ACCESS_STREAM:
  77             p = "STREAM";
  78             break;
  79           default:
  80             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
  81           }
  82
  83       cf_strcpy (iqp->access, iqp->access_len, p);
  84     }
  85
  86   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
  87     {
  88       if (u == NULL)
  89         p = inquire_sequential (NULL, 0);
  90       else
  91         {
  92           /* disallow an open direct access file to be accessed sequentially */
  93           if (u->flags.access == ACCESS_DIRECT)
  94             p = "NO";
  95           else
  96             p = inquire_sequential (u->file, u->file_len);
  97         }
  98
  99       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
 100     }
 101
 102   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
 103     {
 104       p = (u == NULL) ? inquire_direct (NULL, 0) :
 105         inquire_direct (u->file, u->file_len);
 106
 107       cf_strcpy (iqp->direct, iqp->direct_len, p);
 108     }
 109
 110   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
 111     {
 112       if (u == NULL)
 113         p = undefined;
 114       else
 115         switch (u->flags.form)
 116           {
 117           case FORM_FORMATTED:
 118             p = "FORMATTED";
 119             break;
 120           case FORM_UNFORMATTED:
 121             p = "UNFORMATTED";
 122             break;
 123           default:
 124             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
 125           }
 126
 127       cf_strcpy (iqp->form, iqp->form_len, p);
 128     }
 129
 130   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
 131     {
 132       p = (u == NULL) ? inquire_formatted (NULL, 0) :
 133         inquire_formatted (u->file, u->file_len);
 134
 135       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
 136     }
 137
 138   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
 139     {
 140       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
 141         inquire_unformatted (u->file, u->file_len);
 142
 143       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
 144     }
 145
 146   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
 147     *iqp->recl_out = (u != NULL) ? u->recl : 0;
 148
 149   if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
 150     *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0;
 151
 152   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
 153     {
 154       /* This only makes sense in the context of DIRECT access.  */
 155       if (u != NULL && u->flags.access == ACCESS_DIRECT)
 156         *iqp->nextrec = u->last_record + 1;
 157       else
 158         *iqp->nextrec = 0;
 159     }
 160
 161   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
 162     {
 163       if (u == NULL)
 164         p = undefined;
 165       else
 166         switch (u->flags.blank)
 167           {
 168           case BLANK_NULL:
 169             p = "NULL";
 170             break;
 171           case BLANK_ZERO:
 172             p = "ZERO";
 173             break;
 174           default:
 175             internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
 176           }
 177
 178       cf_strcpy (iqp->blank, iqp->blank_len, p);
 179     }
 180
 181   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
 182     {
 183       if (u == NULL || u->flags.access == ACCESS_DIRECT)
 184         p = undefined;
 185       else
 186         switch (u->flags.position)
 187           {
 188              case POSITION_REWIND:
 189                p = "REWIND";
 190                break;
 191              case POSITION_APPEND:
 192                p = "APPEND";
 193                break;
 194              case POSITION_ASIS:
 195                p = "ASIS";
 196                break;
 197              default:
 198                /* if not direct access, it must be
 199                   either REWIND, APPEND, or ASIS.
 200                   ASIS seems to be the best default */
 201                p = "ASIS";
 202                break;
 203           }
 204       cf_strcpy (iqp->position, iqp->position_len, p);
 205     }
 206
 207   if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
 208     {
 209       if (u == NULL)
 210         p = undefined;
 211       else
 212         switch (u->flags.action)
 213           {
 214           case ACTION_READ:
 215             p = "READ";
 216             break;
 217           case ACTION_WRITE:
 218             p = "WRITE";
 219             break;
 220           case ACTION_READWRITE:
 221             p = "READWRITE";
 222             break;
 223           default:
 224             internal_error (&iqp->common, "inquire_via_unit(): Bad action");
 225           }
 226
 227       cf_strcpy (iqp->action, iqp->action_len, p);
 228     }
 229
 230   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
 231     {
 232       p = (u == NULL) ? inquire_read (NULL, 0) :
 233         inquire_read (u->file, u->file_len);
 234
 235       cf_strcpy (iqp->read, iqp->read_len, p);
 236     }
 237
 238   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
 239     {
 240       p = (u == NULL) ? inquire_write (NULL, 0) :
 241         inquire_write (u->file, u->file_len);
 242
 243       cf_strcpy (iqp->write, iqp->write_len, p);
 244     }
 245
 246   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
 247     {
 248       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
 249         inquire_readwrite (u->file, u->file_len);
 250
 251       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
 252     }
 253
 254   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
 255     {
 256       if (u == NULL || u->flags.form != FORM_FORMATTED)
 257         p = undefined;
 258       else
 259         switch (u->flags.delim)
 260           {
 261           case DELIM_NONE:
 262             p = "NONE";
 263             break;
 264           case DELIM_QUOTE:
 265             p = "QUOTE";
 266             break;
 267           case DELIM_APOSTROPHE:
 268             p = "APOSTROPHE";
 269             break;
 270           default:
 271             internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
 272           }
 273
 274       cf_strcpy (iqp->delim, iqp->delim_len, p);
 275     }
 276
 277   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 278     {
 279       if (u == NULL || u->flags.form != FORM_FORMATTED)
 280         p = undefined;
 281       else
 282         switch (u->flags.pad)
 283           {
 284           case PAD_NO:
 285             p = "NO";
 286             break;
 287           case PAD_YES:
 288             p = "YES";
 289             break;
 290           default:
 291             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
 292           }
 293
 294       cf_strcpy (iqp->pad, iqp->pad_len, p);
 295     }
 296
 297   if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
 298     {
 299       if (u == NULL)
 300         p = undefined;
 301       else
 302         switch (u->flags.convert)
 303           {
 304             /*  l8_to_l4_offset is 0 for little-endian, 1 for big-endian.  */
 305           case GFC_CONVERT_NATIVE:
 306             p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
 307             break;
 308
 309           case GFC_CONVERT_SWAP:
 310             p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
 311             break;
 312
 313           default:
 314             internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
 315           }
 316
 317       cf_strcpy (iqp->convert, iqp->convert_len, p);
 318     }
 319 }
 320
 321
 322 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
 323  * only used if the filename is *not* connected to a unit number. */
 324
 325 static void
 326 inquire_via_filename (st_parameter_inquire *iqp)
 327 {
 328   const char *p;
 329   GFC_INTEGER_4 cf = iqp->common.flags;
 330
 331   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
 332     *iqp->exist = file_exists (iqp->file, iqp->file_len);
 333
 334   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
 335     *iqp->opened = 0;
 336
 337   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
 338     *iqp->number = -1;
 339
 340   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
 341     *iqp->named = 1;
 342
 343   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
 344     fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
 345
 346   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 347     cf_strcpy (iqp->access, iqp->access_len, undefined);
 348
 349   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
 350     {
 351       p = inquire_sequential (iqp->file, iqp->file_len);
 352       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
 353     }
 354
 355   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
 356     {
 357       p = inquire_direct (iqp->file, iqp->file_len);
 358       cf_strcpy (iqp->direct, iqp->direct_len, p);
 359     }
 360
 361   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
 362     cf_strcpy (iqp->form, iqp->form_len, undefined);
 363
 364   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
 365     {
 366       p = inquire_formatted (iqp->file, iqp->file_len);
 367       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
 368     }
 369
 370   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
 371     {
 372       p = inquire_unformatted (iqp->file, iqp->file_len);
 373       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
 374     }
 375
 376   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
 377     *iqp->recl_out = 0;
 378
 379   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
 380     *iqp->nextrec = 0;
 381
 382   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
 383     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
 384
 385   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
 386     cf_strcpy (iqp->position, iqp->position_len, undefined);
 387
 388   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
 389     cf_strcpy (iqp->access, iqp->access_len, undefined);
 390
 391   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
 392     {
 393       p = inquire_read (iqp->file, iqp->file_len);
 394       cf_strcpy (iqp->read, iqp->read_len, p);
 395     }
 396
 397   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
 398     {
 399       p = inquire_write (iqp->file, iqp->file_len);
 400       cf_strcpy (iqp->write, iqp->write_len, p);
 401     }
 402
 403   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
 404     {
 405       p = inquire_read (iqp->file, iqp->file_len);
 406       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
 407     }
 408
 409   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
 410     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 411
 412   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
 413     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 414 }
 415
 416
 417 /* Library entry point for the INQUIRE statement (non-IOLENGTH
 418    form).  */
 419
 420 extern void st_inquire (st_parameter_inquire *);
 421 export_proto(st_inquire);
 422
 423 void
 424 st_inquire (st_parameter_inquire *iqp)
 425 {
 426   gfc_unit *u;
 427
 428   library_start (&iqp->common);
 429
 430   if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
 431     {
 432       u = find_unit (iqp->common.unit);
 433       inquire_via_unit (iqp, u);
 434     }
 435   else
 436     {
 437       u = find_file (iqp->file, iqp->file_len);
 438       if (u == NULL)
 439         inquire_via_filename (iqp);
 440       else
 441         inquire_via_unit (iqp, u);
 442     }
 443   if (u != NULL)
 444     unlock_unit (u);
 445
 446   library_end ();
 447 }