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