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 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with Libgfortran; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21
  22 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
  23
  24 #include "config.h"
  25 #include "libgfortran.h"
  26 #include "io.h"
  27
  28
  29 static char undefined[] = "UNDEFINED";
  30
  31
  32 /* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */
  33
  34 static void
  35 inquire_via_unit (gfc_unit * u)
  36 {
  37   const char *p;
  38
  39   if (ioparm.exist != NULL)
  40     *ioparm.exist = (u != NULL);
  41
  42   if (ioparm.opened != NULL)
  43     *ioparm.opened = (u != NULL);
  44
  45   if (ioparm.number != NULL)
  46     *ioparm.number = (u != NULL) ? u->unit_number : -1;
  47
  48   if (ioparm.named != NULL)
  49     *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
  50
  51   if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
  52     fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
  53
  54   if (ioparm.access != NULL)
  55     {
  56       if (u == NULL)
  57         p = undefined;
  58       else
  59         switch (u->flags.access)
  60           {
  61           case ACCESS_SEQUENTIAL:
  62             p = "SEQUENTIAL";
  63             break;
  64           case ACCESS_DIRECT:
  65             p = "DIRECT";
  66             break;
  67           default:
  68             internal_error ("inquire_via_unit(): Bad access");
  69           }
  70
  71       cf_strcpy (ioparm.access, ioparm.access_len, p);
  72     }
  73
  74   if (ioparm.sequential != NULL)
  75     {
  76       p = (u == NULL) ? inquire_sequential (NULL, 0) :
  77         inquire_sequential (u->file, u->file_len);
  78
  79       cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
  80     }
  81
  82   if (ioparm.direct != NULL)
  83     {
  84       p = (u == NULL) ? inquire_direct (NULL, 0) :
  85         inquire_direct (u->file, u->file_len);
  86
  87       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
  88     }
  89
  90   if (ioparm.form != NULL)
  91     {
  92       if (u == NULL)
  93         p = undefined;
  94       else
  95         switch (u->flags.form)
  96           {
  97           case FORM_FORMATTED:
  98             p = "FORMATTED";
  99             break;
 100           case FORM_UNFORMATTED:
 101             p = "UNFORMATTED";
 102             break;
 103           default:
 104             internal_error ("inquire_via_unit(): Bad form");
 105           }
 106
 107       cf_strcpy (ioparm.form, ioparm.form_len, p);
 108     }
 109
 110   if (ioparm.formatted != NULL)
 111     {
 112       p = (u == NULL) ? inquire_formatted (NULL, 0) :
 113         inquire_formatted (u->file, u->file_len);
 114
 115       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
 116     }
 117
 118   if (ioparm.unformatted != NULL)
 119     {
 120       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
 121         inquire_unformatted (u->file, u->file_len);
 122
 123       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
 124     }
 125
 126   if (ioparm.recl_out != NULL)
 127     *ioparm.recl_out = (u != NULL) ? u->recl : 0;
 128
 129   if (ioparm.nextrec != NULL)
 130     *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
 131
 132   if (ioparm.blank != NULL)
 133     {
 134       if (u == NULL)
 135         p = undefined;
 136       else
 137         switch (u->flags.blank)
 138           {
 139           case BLANK_NULL:
 140           p = "NULL";
 141             break;
 142           case BLANK_ZERO:
 143             p = "ZERO";
 144             break;
 145           default:
 146             internal_error ("inquire_via_unit(): Bad blank");
 147           }
 148
 149       cf_strcpy (ioparm.blank, ioparm.blank_len, p);
 150     }
 151
 152   if (ioparm.position != NULL)
 153     {
 154       if (u == NULL || u->flags.access == ACCESS_DIRECT)
 155         p = undefined;
 156       else
 157         {
 158           p = NULL;             /* TODO: Try to decode what the standard says... */
 159         }
 160
 161       cf_strcpy (ioparm.blank, ioparm.blank_len, p);
 162     }
 163
 164   if (ioparm.action != NULL)
 165     {
 166       if (u == NULL)
 167         p = undefined;
 168       else
 169         switch (u->flags.action)
 170           {
 171           case ACTION_READ:
 172             p = "READ";
 173             break;
 174           case ACTION_WRITE:
 175             p = "WRITE";
 176             break;
 177           case ACTION_READWRITE:
 178             p = "READWRITE";
 179             break;
 180           default:
 181             internal_error ("inquire_via_unit(): Bad action");
 182           }
 183
 184       cf_strcpy (ioparm.action, ioparm.action_len, p);
 185     }
 186
 187   if (ioparm.read != NULL)
 188     {
 189       p = (u == NULL) ? inquire_read (NULL, 0) :
 190         inquire_read (u->file, u->file_len);
 191
 192       cf_strcpy (ioparm.read, ioparm.read_len, p);
 193     }
 194
 195   if (ioparm.write != NULL)
 196     {
 197       p = (u == NULL) ? inquire_write (NULL, 0) :
 198         inquire_write (u->file, u->file_len);
 199
 200       cf_strcpy (ioparm.write, ioparm.write_len, p);
 201     }
 202
 203   if (ioparm.readwrite != NULL)
 204     {
 205       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
 206         inquire_readwrite (u->file, u->file_len);
 207
 208       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
 209     }
 210
 211   if (ioparm.delim != NULL)
 212     {
 213       if (u == NULL || u->flags.form != FORM_FORMATTED)
 214         p = undefined;
 215       else
 216         switch (u->flags.delim)
 217           {
 218           case DELIM_NONE:
 219             p = "NONE";
 220             break;
 221           case DELIM_QUOTE:
 222             p = "QUOTE";
 223             break;
 224           case DELIM_APOSTROPHE:
 225             p = "APOSTROPHE";
 226             break;
 227           default:
 228             internal_error ("inquire_via_unit(): Bad delim");
 229           }
 230
 231       cf_strcpy (ioparm.access, ioparm.access_len, p);
 232     }
 233
 234   if (ioparm.pad != NULL)
 235     {
 236       if (u == NULL || u->flags.form != FORM_FORMATTED)
 237         p = undefined;
 238       else
 239         switch (u->flags.pad)
 240           {
 241           case PAD_NO:
 242             p = "NO";
 243             break;
 244           case PAD_YES:
 245             p = "YES";
 246             break;
 247           default:
 248             internal_error ("inquire_via_unit(): Bad pad");
 249           }
 250
 251       cf_strcpy (ioparm.pad, ioparm.pad_len, p);
 252     }
 253 }
 254
 255
 256 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
 257  * only used if the filename is *not* connected to a unit number. */
 258
 259 static void
 260 inquire_via_filename (void)
 261 {
 262   const char *p;
 263
 264   if (ioparm.exist != NULL)
 265     *ioparm.exist = file_exists ();
 266
 267   if (ioparm.opened != NULL)
 268     *ioparm.opened = 0;
 269
 270   if (ioparm.number != NULL)
 271     *ioparm.number = -1;
 272
 273   if (ioparm.named != NULL)
 274     *ioparm.named = 1;
 275
 276   if (ioparm.name != NULL)
 277     fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
 278
 279   if (ioparm.access != NULL)
 280     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
 281
 282   if (ioparm.sequential != NULL)
 283     {
 284       p = inquire_sequential (ioparm.file, ioparm.file_len);
 285       cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
 286     }
 287
 288   if (ioparm.direct != NULL)
 289     {
 290       p = inquire_direct (ioparm.file, ioparm.file_len);
 291       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
 292     }
 293
 294   if (ioparm.form != NULL)
 295     cf_strcpy (ioparm.form, ioparm.form_len, undefined);
 296
 297   if (ioparm.formatted != NULL)
 298     {
 299       p = inquire_formatted (ioparm.file, ioparm.file_len);
 300       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
 301     }
 302
 303   if (ioparm.unformatted != NULL)
 304     {
 305       p = inquire_unformatted (ioparm.file, ioparm.file_len);
 306       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
 307     }
 308
 309   if (ioparm.recl_out != NULL)
 310     *ioparm.recl_out = 0;
 311
 312   if (ioparm.nextrec != NULL)
 313     *ioparm.nextrec = 0;
 314
 315   if (ioparm.blank != NULL)
 316     cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
 317
 318   if (ioparm.position != NULL)
 319     cf_strcpy (ioparm.position, ioparm.position_len, undefined);
 320
 321   if (ioparm.access != NULL)
 322     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
 323
 324   if (ioparm.read != NULL)
 325     {
 326       p = inquire_read (ioparm.file, ioparm.file_len);
 327       cf_strcpy (ioparm.read, ioparm.read_len, p);
 328     }
 329
 330   if (ioparm.write != NULL)
 331     {
 332       p = inquire_write (ioparm.file, ioparm.file_len);
 333       cf_strcpy (ioparm.write, ioparm.write_len, p);
 334     }
 335
 336   if (ioparm.readwrite != NULL)
 337     {
 338       p = inquire_read (ioparm.file, ioparm.file_len);
 339       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
 340     }
 341
 342   if (ioparm.delim != NULL)
 343     cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
 344
 345   if (ioparm.pad != NULL)
 346     cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
 347
 348 }
 349
 350
 351 /* Library entry point for the INQUIRE statement (non-IOLENGTH
 352    form).  */
 353
 354 void
 355 st_inquire (void)
 356 {
 357   gfc_unit *u;
 358
 359   library_start ();
 360
 361   if (ioparm.file == NULL)
 362     inquire_via_unit (find_unit (ioparm.unit));
 363   else
 364     {
 365       u = find_file ();
 366       if (u == NULL)
 367         inquire_via_filename ();
 368       else
 369         inquire_via_unit (u);
 370     }
 371
 372   library_end ();
 373 }