1 /* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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)
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
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.
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. */
31 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
36 static const char undefined
[] = "UNDEFINED";
39 /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
42 inquire_via_unit (st_parameter_inquire
*iqp
, gfc_unit
* u
)
45 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
47 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
49 *iqp
->exist
= (iqp
->common
.unit
>= 0
50 && iqp
->common
.unit
<= GFC_INTEGER_4_HUGE
);
52 if ((cf
& IOPARM_INQUIRE_HAS_FILE
) == 0)
55 *iqp
->common
.iostat
= LIBERROR_BAD_UNIT
;
56 *iqp
->exist
= *iqp
->exist
57 && (*iqp
->common
.iostat
!= LIBERROR_BAD_UNIT
);
61 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
62 *iqp
->opened
= (u
!= NULL
);
64 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
65 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
67 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
68 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
70 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
71 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
72 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
74 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
79 switch (u
->flags
.access
)
81 case ACCESS_SEQUENTIAL
:
91 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
94 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
97 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
100 p
= inquire_sequential (NULL
, 0);
102 switch (u
->flags
.access
)
108 case ACCESS_SEQUENTIAL
:
112 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
115 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
118 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
121 p
= inquire_direct (NULL
, 0);
123 switch (u
->flags
.access
)
125 case ACCESS_SEQUENTIAL
:
133 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
136 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
139 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
144 switch (u
->flags
.form
)
149 case FORM_UNFORMATTED
:
153 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
156 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
159 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
162 p
= inquire_formatted (NULL
, 0);
164 switch (u
->flags
.form
)
169 case FORM_UNFORMATTED
:
173 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
176 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
179 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
182 p
= inquire_unformatted (NULL
, 0);
184 switch (u
->flags
.form
)
189 case FORM_UNFORMATTED
:
193 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
196 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
199 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
200 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: 0;
202 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
203 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
205 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
207 /* This only makes sense in the context of DIRECT access. */
208 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
209 *iqp
->nextrec
= u
->last_record
+ 1;
214 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
219 switch (u
->flags
.blank
)
228 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
231 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
234 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
236 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
239 switch (u
->flags
.position
)
241 case POSITION_REWIND
:
244 case POSITION_APPEND
:
251 /* if not direct access, it must be
252 either REWIND, APPEND, or ASIS.
253 ASIS seems to be the best default */
257 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
260 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
265 switch (u
->flags
.action
)
273 case ACTION_READWRITE
:
277 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
280 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
283 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
285 p
= (u
== NULL
) ? inquire_read (NULL
, 0) :
286 inquire_read (u
->file
, u
->file_len
);
288 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
291 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
293 p
= (u
== NULL
) ? inquire_write (NULL
, 0) :
294 inquire_write (u
->file
, u
->file_len
);
296 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
299 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
301 p
= (u
== NULL
) ? inquire_readwrite (NULL
, 0) :
302 inquire_readwrite (u
->file
, u
->file_len
);
304 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
307 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
309 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
312 switch (u
->flags
.delim
)
320 case DELIM_APOSTROPHE
:
324 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
327 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
330 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
332 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
335 switch (u
->flags
.pad
)
344 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
347 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
350 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
355 switch (u
->flags
.convert
)
357 /* l8_to_l4_offset is 0 for little-endian, 1 for big-endian. */
358 case GFC_CONVERT_NATIVE
:
359 p
= l8_to_l4_offset
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
362 case GFC_CONVERT_SWAP
:
363 p
= l8_to_l4_offset
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
367 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
370 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
375 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
376 * only used if the filename is *not* connected to a unit number. */
379 inquire_via_filename (st_parameter_inquire
*iqp
)
382 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
384 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
385 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
387 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
390 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
393 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
396 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
397 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
399 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
400 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
402 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
405 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
408 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
411 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
414 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
415 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
417 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
420 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
423 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
426 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
429 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
432 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
435 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
436 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
438 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
439 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
441 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
442 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
444 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
446 p
= inquire_read (iqp
->file
, iqp
->file_len
);
447 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
450 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
452 p
= inquire_write (iqp
->file
, iqp
->file_len
);
453 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
456 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
458 p
= inquire_read (iqp
->file
, iqp
->file_len
);
459 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
462 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
463 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
465 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
466 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
470 /* Library entry point for the INQUIRE statement (non-IOLENGTH
473 extern void st_inquire (st_parameter_inquire
*);
474 export_proto(st_inquire
);
477 st_inquire (st_parameter_inquire
*iqp
)
481 library_start (&iqp
->common
);
483 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
485 u
= find_unit (iqp
->common
.unit
);
486 inquire_via_unit (iqp
, u
);
490 u
= find_file (iqp
->file
, iqp
->file_len
);
492 inquire_via_filename (iqp
);
494 inquire_via_unit (iqp
, u
);