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