1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009 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 3, or (at your option)
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.
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23 <http://www.gnu.org/licenses/>. */
26 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
31 static const char undefined
[] = "UNDEFINED";
34 /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
37 inquire_via_unit (st_parameter_inquire
*iqp
, gfc_unit
* u
)
40 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
42 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
44 *iqp
->exist
= (iqp
->common
.unit
>= 0
45 && iqp
->common
.unit
<= GFC_INTEGER_4_HUGE
);
47 if ((cf
& IOPARM_INQUIRE_HAS_FILE
) == 0)
50 *iqp
->common
.iostat
= LIBERROR_BAD_UNIT
;
51 *iqp
->exist
= *iqp
->exist
52 && (*iqp
->common
.iostat
!= LIBERROR_BAD_UNIT
);
56 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
57 *iqp
->opened
= (u
!= NULL
);
59 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
60 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
62 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
63 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
65 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
66 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
67 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
69 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
74 switch (u
->flags
.access
)
76 case ACCESS_SEQUENTIAL
:
86 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
89 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
92 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
95 p
= inquire_sequential (NULL
, 0);
97 switch (u
->flags
.access
)
103 case ACCESS_SEQUENTIAL
:
107 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
110 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
113 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
116 p
= inquire_direct (NULL
, 0);
118 switch (u
->flags
.access
)
120 case ACCESS_SEQUENTIAL
:
128 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
131 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
134 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
139 switch (u
->flags
.form
)
144 case FORM_UNFORMATTED
:
148 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
151 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
154 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
157 p
= inquire_formatted (NULL
, 0);
159 switch (u
->flags
.form
)
164 case FORM_UNFORMATTED
:
168 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
171 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
174 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
177 p
= inquire_unformatted (NULL
, 0);
179 switch (u
->flags
.form
)
184 case FORM_UNFORMATTED
:
188 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
191 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
194 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
195 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: 0;
197 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
198 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
200 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
202 /* This only makes sense in the context of DIRECT access. */
203 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
204 *iqp
->nextrec
= u
->last_record
+ 1;
209 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
211 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
214 switch (u
->flags
.blank
)
223 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
226 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
229 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
231 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
234 switch (u
->flags
.pad
)
243 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
246 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
249 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
251 GFC_INTEGER_4 cf2
= iqp
->flags2
;
253 if ((cf2
& IOPARM_INQUIRE_HAS_PENDING
) != 0)
256 if ((cf2
& IOPARM_INQUIRE_HAS_ID
) != 0)
259 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
261 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
264 switch (u
->flags
.encoding
)
266 case ENCODING_DEFAULT
:
273 internal_error (&iqp
->common
, "inquire_via_unit(): Bad encoding");
276 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, p
);
279 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
281 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
284 switch (u
->flags
.decimal
)
293 internal_error (&iqp
->common
, "inquire_via_unit(): Bad comma");
296 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, p
);
299 if ((cf2
& IOPARM_INQUIRE_HAS_ASYNCHRONOUS
) != 0)
304 switch (u
->flags
.async
)
313 internal_error (&iqp
->common
, "inquire_via_unit(): Bad async");
316 cf_strcpy (iqp
->asynchronous
, iqp
->asynchronous_len
, p
);
319 if ((cf2
& IOPARM_INQUIRE_HAS_SIGN
) != 0)
324 switch (u
->flags
.sign
)
326 case SIGN_PROCDEFINED
:
327 p
= "PROCESSOR_DEFINED";
336 internal_error (&iqp
->common
, "inquire_via_unit(): Bad sign");
339 cf_strcpy (iqp
->sign
, iqp
->sign_len
, p
);
342 if ((cf2
& IOPARM_INQUIRE_HAS_ROUND
) != 0)
347 switch (u
->flags
.round
)
361 case ROUND_COMPATIBLE
:
364 case ROUND_PROCDEFINED
:
365 p
= "PROCESSOR_DEFINED";
368 internal_error (&iqp
->common
, "inquire_via_unit(): Bad round");
371 cf_strcpy (iqp
->round
, iqp
->round_len
, p
);
375 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
377 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
380 switch (u
->flags
.position
)
382 case POSITION_REWIND
:
385 case POSITION_APPEND
:
392 /* if not direct access, it must be
393 either REWIND, APPEND, or ASIS.
394 ASIS seems to be the best default */
398 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
401 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
406 switch (u
->flags
.action
)
414 case ACTION_READWRITE
:
418 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
421 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
424 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
426 p
= (u
== NULL
) ? inquire_read (NULL
, 0) :
427 inquire_read (u
->file
, u
->file_len
);
429 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
432 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
434 p
= (u
== NULL
) ? inquire_write (NULL
, 0) :
435 inquire_write (u
->file
, u
->file_len
);
437 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
440 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
442 p
= (u
== NULL
) ? inquire_readwrite (NULL
, 0) :
443 inquire_readwrite (u
->file
, u
->file_len
);
445 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
448 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
450 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
453 switch (u
->flags
.delim
)
461 case DELIM_APOSTROPHE
:
465 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
468 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
471 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
473 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
476 switch (u
->flags
.pad
)
485 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
488 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
491 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
496 switch (u
->flags
.convert
)
498 /* big_endian is 0 for little-endian, 1 for big-endian. */
499 case GFC_CONVERT_NATIVE
:
500 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
503 case GFC_CONVERT_SWAP
:
504 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
508 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
511 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
516 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
517 * only used if the filename is *not* connected to a unit number. */
520 inquire_via_filename (st_parameter_inquire
*iqp
)
523 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
525 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
526 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
528 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
531 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
534 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
537 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
538 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
540 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
541 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
543 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
546 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
549 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
552 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
555 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
556 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
558 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
561 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
564 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
567 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
570 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
573 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
576 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
577 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
579 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
580 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
582 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
584 GFC_INTEGER_4 cf2
= iqp
->flags2
;
586 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
587 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
589 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
590 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
592 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
593 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
595 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
596 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
598 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
599 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
601 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
602 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
605 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
606 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
608 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
609 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
611 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
613 p
= inquire_read (iqp
->file
, iqp
->file_len
);
614 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
617 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
619 p
= inquire_write (iqp
->file
, iqp
->file_len
);
620 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
623 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
625 p
= inquire_read (iqp
->file
, iqp
->file_len
);
626 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
631 /* Library entry point for the INQUIRE statement (non-IOLENGTH
634 extern void st_inquire (st_parameter_inquire
*);
635 export_proto(st_inquire
);
638 st_inquire (st_parameter_inquire
*iqp
)
642 library_start (&iqp
->common
);
644 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
646 u
= find_unit (iqp
->common
.unit
);
647 inquire_via_unit (iqp
, u
);
651 u
= find_file (iqp
->file
, iqp
->file_len
);
653 inquire_via_filename (iqp
);
655 inquire_via_unit (iqp
, u
);