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