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