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