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
;
46 GFC_INTEGER_4 cf2
= iqp
->flags2
;
48 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
50 *iqp
->exist
= (iqp
->common
.unit
>= 0
51 && iqp
->common
.unit
<= GFC_INTEGER_4_HUGE
);
53 if ((cf
& IOPARM_INQUIRE_HAS_FILE
) == 0)
56 *iqp
->common
.iostat
= LIBERROR_BAD_UNIT
;
57 *iqp
->exist
= *iqp
->exist
58 && (*iqp
->common
.iostat
!= LIBERROR_BAD_UNIT
);
62 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
63 *iqp
->opened
= (u
!= NULL
);
65 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
66 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
68 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
69 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
71 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
72 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
73 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
75 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
80 switch (u
->flags
.access
)
82 case ACCESS_SEQUENTIAL
:
92 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
95 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
98 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
101 p
= inquire_sequential (NULL
, 0);
103 switch (u
->flags
.access
)
109 case ACCESS_SEQUENTIAL
:
113 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
116 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
119 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
122 p
= inquire_direct (NULL
, 0);
124 switch (u
->flags
.access
)
126 case ACCESS_SEQUENTIAL
:
134 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
137 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
140 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
145 switch (u
->flags
.form
)
150 case FORM_UNFORMATTED
:
154 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
157 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
160 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
163 p
= inquire_formatted (NULL
, 0);
165 switch (u
->flags
.form
)
170 case FORM_UNFORMATTED
:
174 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
177 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
180 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
183 p
= inquire_unformatted (NULL
, 0);
185 switch (u
->flags
.form
)
190 case FORM_UNFORMATTED
:
194 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
197 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
200 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
201 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: 0;
203 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
204 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
206 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
208 /* This only makes sense in the context of DIRECT access. */
209 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
210 *iqp
->nextrec
= u
->last_record
+ 1;
215 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
217 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
220 switch (u
->flags
.blank
)
229 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
232 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
235 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
237 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
240 switch (u
->flags
.pad
)
249 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
252 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
255 if ((cf2
& IOPARM_INQUIRE_HAS_PENDING
) != 0)
258 if ((cf2
& IOPARM_INQUIRE_HAS_ID
) != 0)
261 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
263 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
266 switch (u
->flags
.encoding
)
268 case ENCODING_DEFAULT
:
271 /* TODO: Enable UTF-8 case here when implemented.
276 internal_error (&iqp
->common
, "inquire_via_unit(): Bad encoding");
279 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, p
);
282 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
284 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
287 switch (u
->flags
.decimal
)
296 internal_error (&iqp
->common
, "inquire_via_unit(): Bad comma");
299 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, p
);
302 if ((cf2
& IOPARM_INQUIRE_HAS_ASYNCHRONOUS
) != 0)
307 switch (u
->flags
.async
)
316 internal_error (&iqp
->common
, "inquire_via_unit(): Bad async");
319 cf_strcpy (iqp
->asynchronous
, iqp
->asynchronous_len
, p
);
322 if ((cf2
& IOPARM_INQUIRE_HAS_SIGN
) != 0)
327 switch (u
->flags
.sign
)
329 case SIGN_PROCDEFINED
:
330 p
= "PROCESSOR_DEFINED";
339 internal_error (&iqp
->common
, "inquire_via_unit(): Bad sign");
342 cf_strcpy (iqp
->sign
, iqp
->sign_len
, p
);
345 if ((cf2
& IOPARM_INQUIRE_HAS_ROUND
) != 0)
350 switch (u
->flags
.round
)
364 case ROUND_COMPATIBLE
:
367 case ROUND_PROCDEFINED
:
368 p
= "PROCESSOR_DEFINED";
371 internal_error (&iqp
->common
, "inquire_via_unit(): Bad round");
374 cf_strcpy (iqp
->round
, iqp
->round_len
, p
);
377 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
379 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
382 switch (u
->flags
.position
)
384 case POSITION_REWIND
:
387 case POSITION_APPEND
:
394 /* if not direct access, it must be
395 either REWIND, APPEND, or ASIS.
396 ASIS seems to be the best default */
400 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
403 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
408 switch (u
->flags
.action
)
416 case ACTION_READWRITE
:
420 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
423 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
426 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
428 p
= (u
== NULL
) ? inquire_read (NULL
, 0) :
429 inquire_read (u
->file
, u
->file_len
);
431 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
434 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
436 p
= (u
== NULL
) ? inquire_write (NULL
, 0) :
437 inquire_write (u
->file
, u
->file_len
);
439 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
442 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
444 p
= (u
== NULL
) ? inquire_readwrite (NULL
, 0) :
445 inquire_readwrite (u
->file
, u
->file_len
);
447 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
450 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
452 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
455 switch (u
->flags
.delim
)
463 case DELIM_APOSTROPHE
:
467 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
470 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
473 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
475 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
478 switch (u
->flags
.pad
)
487 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
490 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
493 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
498 switch (u
->flags
.convert
)
500 /* l8_to_l4_offset is 0 for little-endian, 1 for big-endian. */
501 case GFC_CONVERT_NATIVE
:
502 p
= l8_to_l4_offset
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
505 case GFC_CONVERT_SWAP
:
506 p
= l8_to_l4_offset
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
510 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
513 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
518 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
519 * only used if the filename is *not* connected to a unit number. */
522 inquire_via_filename (st_parameter_inquire
*iqp
)
525 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
526 GFC_INTEGER_4 cf2
= iqp
->flags2
;
528 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
529 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
531 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
534 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
537 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
540 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
541 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
543 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
544 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
546 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
549 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
552 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
555 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
558 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
559 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
561 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
564 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
567 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
570 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
573 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
576 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
579 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
580 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
582 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
583 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
585 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
586 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
588 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
589 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
591 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
592 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
594 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
595 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
597 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
598 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
600 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
602 p
= inquire_read (iqp
->file
, iqp
->file_len
);
603 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
606 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
608 p
= inquire_write (iqp
->file
, iqp
->file_len
);
609 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
612 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
614 p
= inquire_read (iqp
->file
, iqp
->file_len
);
615 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
618 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
619 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
621 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
622 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
624 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
625 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
629 /* Library entry point for the INQUIRE statement (non-IOLENGTH
632 extern void st_inquire (st_parameter_inquire
*);
633 export_proto(st_inquire
);
636 st_inquire (st_parameter_inquire
*iqp
)
640 library_start (&iqp
->common
);
642 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
644 u
= find_unit (iqp
->common
.unit
);
645 inquire_via_unit (iqp
, u
);
649 u
= find_file (iqp
->file
, iqp
->file_len
);
651 inquire_via_filename (iqp
);
653 inquire_via_unit (iqp
, u
);