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