libgfortran/io/inquire.c

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