libgfortran/io/inquire.c

   1 /* Copyright (C) 2002-2003 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, 59 Temple Place - Suite 330,
  28 Boston, MA 02111-1307, 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 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 (gfc_unit * u)
  45 {
  46   const char *p;
  47
  48   if (ioparm.exist != NULL)
  49   {
  50     if (ioparm.unit >= 0)
  51       *ioparm.exist = 1;
  52     else
  53       *ioparm.exist = 0;
  54   }
  55
  56   if (ioparm.opened != NULL)
  57     *ioparm.opened = (u != NULL);
  58
  59   if (ioparm.number != NULL)
  60     *ioparm.number = (u != NULL) ? u->unit_number : -1;
  61
  62   if (ioparm.named != NULL)
  63     *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
  64
  65   if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
  66     fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
  67
  68   if (ioparm.access != NULL)
  69     {
  70       if (u == NULL)
  71         p = undefined;
  72       else
  73         switch (u->flags.access)
  74           {
  75           case ACCESS_SEQUENTIAL:
  76             p = "SEQUENTIAL";
  77             break;
  78           case ACCESS_DIRECT:
  79             p = "DIRECT";
  80             break;
  81           default:
  82             internal_error ("inquire_via_unit(): Bad access");
  83           }
  84
  85       cf_strcpy (ioparm.access, ioparm.access_len, p);
  86     }
  87
  88   if (ioparm.sequential != NULL)
  89     {
  90       /* disallow an open direct access file to be accessed
  91          sequentially */
  92       if (u->flags.access==ACCESS_DIRECT)
  93         p = "NO";
  94       else
  95         p = (u == NULL) ? inquire_sequential (NULL, 0) :
  96         inquire_sequential (u->file, u->file_len);
  97
  98       cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
  99     }
 100
 101   if (ioparm.direct != NULL)
 102     {
 103       p = (u == NULL) ? inquire_direct (NULL, 0) :
 104         inquire_direct (u->file, u->file_len);
 105
 106       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
 107     }
 108
 109   if (ioparm.form != NULL)
 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 ("inquire_via_unit(): Bad form");
 124           }
 125
 126       cf_strcpy (ioparm.form, ioparm.form_len, p);
 127     }
 128
 129   if (ioparm.formatted != NULL)
 130     {
 131       p = (u == NULL) ? inquire_formatted (NULL, 0) :
 132         inquire_formatted (u->file, u->file_len);
 133
 134       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
 135     }
 136
 137   if (ioparm.unformatted != NULL)
 138     {
 139       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
 140         inquire_unformatted (u->file, u->file_len);
 141
 142       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
 143     }
 144
 145   if (ioparm.recl_out != NULL)
 146     *ioparm.recl_out = (u != NULL) ? u->recl : 0;
 147
 148   if (ioparm.nextrec != NULL)
 149     *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
 150
 151   if (ioparm.blank != NULL)
 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 ("inquire_via_unit(): Bad blank");
 166           }
 167
 168       cf_strcpy (ioparm.blank, ioparm.blank_len, p);
 169     }
 170
 171   if (ioparm.position != NULL)
 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 (ioparm.position, ioparm.position_len, p);
 195     }
 196
 197   if (ioparm.action != NULL)
 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 ("inquire_via_unit(): Bad action");
 215           }
 216
 217       cf_strcpy (ioparm.action, ioparm.action_len, p);
 218     }
 219
 220   if (ioparm.read != NULL)
 221     {
 222       p = (u == NULL) ? inquire_read (NULL, 0) :
 223         inquire_read (u->file, u->file_len);
 224
 225       cf_strcpy (ioparm.read, ioparm.read_len, p);
 226     }
 227
 228   if (ioparm.write != NULL)
 229     {
 230       p = (u == NULL) ? inquire_write (NULL, 0) :
 231         inquire_write (u->file, u->file_len);
 232
 233       cf_strcpy (ioparm.write, ioparm.write_len, p);
 234     }
 235
 236   if (ioparm.readwrite != NULL)
 237     {
 238       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
 239         inquire_readwrite (u->file, u->file_len);
 240
 241       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
 242     }
 243
 244   if (ioparm.delim != NULL)
 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 ("inquire_via_unit(): Bad delim");
 262           }
 263
 264       cf_strcpy (ioparm.delim, ioparm.delim_len, p);
 265     }
 266
 267   if (ioparm.pad != NULL)
 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 ("inquire_via_unit(): Bad pad");
 282           }
 283
 284       cf_strcpy (ioparm.pad, ioparm.pad_len, p);
 285     }
 286 }
 287
 288
 289 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
 290  * only used if the filename is *not* connected to a unit number. */
 291
 292 static void
 293 inquire_via_filename (void)
 294 {
 295   const char *p;
 296
 297   if (ioparm.exist != NULL)
 298     *ioparm.exist = file_exists ();
 299
 300   if (ioparm.opened != NULL)
 301     *ioparm.opened = 0;
 302
 303   if (ioparm.number != NULL)
 304     *ioparm.number = -1;
 305
 306   if (ioparm.named != NULL)
 307     *ioparm.named = 1;
 308
 309   if (ioparm.name != NULL)
 310     fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
 311
 312   if (ioparm.access != NULL)
 313     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
 314
 315   if (ioparm.sequential != NULL)
 316     {
 317       p = inquire_sequential (ioparm.file, ioparm.file_len);
 318       cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
 319     }
 320
 321   if (ioparm.direct != NULL)
 322     {
 323       p = inquire_direct (ioparm.file, ioparm.file_len);
 324       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
 325     }
 326
 327   if (ioparm.form != NULL)
 328     cf_strcpy (ioparm.form, ioparm.form_len, undefined);
 329
 330   if (ioparm.formatted != NULL)
 331     {
 332       p = inquire_formatted (ioparm.file, ioparm.file_len);
 333       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
 334     }
 335
 336   if (ioparm.unformatted != NULL)
 337     {
 338       p = inquire_unformatted (ioparm.file, ioparm.file_len);
 339       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
 340     }
 341
 342   if (ioparm.recl_out != NULL)
 343     *ioparm.recl_out = 0;
 344
 345   if (ioparm.nextrec != NULL)
 346     *ioparm.nextrec = 0;
 347
 348   if (ioparm.blank != NULL)
 349     cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
 350
 351   if (ioparm.position != NULL)
 352     cf_strcpy (ioparm.position, ioparm.position_len, undefined);
 353
 354   if (ioparm.access != NULL)
 355     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
 356
 357   if (ioparm.read != NULL)
 358     {
 359       p = inquire_read (ioparm.file, ioparm.file_len);
 360       cf_strcpy (ioparm.read, ioparm.read_len, p);
 361     }
 362
 363   if (ioparm.write != NULL)
 364     {
 365       p = inquire_write (ioparm.file, ioparm.file_len);
 366       cf_strcpy (ioparm.write, ioparm.write_len, p);
 367     }
 368
 369   if (ioparm.readwrite != NULL)
 370     {
 371       p = inquire_read (ioparm.file, ioparm.file_len);
 372       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
 373     }
 374
 375   if (ioparm.delim != NULL)
 376     cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
 377
 378   if (ioparm.pad != NULL)
 379     cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
 380
 381 }
 382
 383
 384 /* Library entry point for the INQUIRE statement (non-IOLENGTH
 385    form).  */
 386
 387 extern void st_inquire (void);
 388 export_proto(st_inquire);
 389
 390 void
 391 st_inquire (void)
 392 {
 393   gfc_unit *u;
 394
 395   library_start ();
 396
 397   if (ioparm.file == NULL)
 398     inquire_via_unit (find_unit (ioparm.unit));
 399   else
 400     {
 401       u = find_file ();
 402       if (u == NULL)
 403         inquire_via_filename ();
 404       else
 405         inquire_via_unit (u);
 406     }
 407
 408   library_end ();
 409 }