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