1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 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 */
33 static const char yes
[] = "YES", no
[] = "NO", undefined
[] = "UNDEFINED";
36 /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
39 inquire_via_unit (st_parameter_inquire
*iqp
, gfc_unit
*u
)
42 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
44 if (iqp
->common
.unit
== GFC_INTERNAL_UNIT
||
45 iqp
->common
.unit
== GFC_INTERNAL_UNIT4
||
46 (u
!= NULL
&& u
->internal_unit_kind
!= 0))
47 generate_error (&iqp
->common
, LIBERROR_INQUIRE_INTERNAL_UNIT
, NULL
);
49 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
50 *iqp
->exist
= (u
!= NULL
&&
51 iqp
->common
.unit
!= GFC_INTERNAL_UNIT
&&
52 iqp
->common
.unit
!= GFC_INTERNAL_UNIT4
)
53 || (iqp
->common
.unit
>= 0);
55 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
56 *iqp
->opened
= (u
!= NULL
);
58 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
59 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
61 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
62 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
64 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
65 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
67 #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME)
68 if (u
->unit_number
== options
.stdin_unit
69 || u
->unit_number
== options
.stdout_unit
70 || u
->unit_number
== options
.stderr_unit
)
72 int err
= stream_ttyname (u
->s
, iqp
->name
, iqp
->name_len
);
75 gfc_charlen_type tmplen
= strlen (iqp
->name
);
76 if (iqp
->name_len
> tmplen
)
77 memset (&iqp
->name
[tmplen
], ' ', iqp
->name_len
- tmplen
);
79 else /* If ttyname does not work, go with the default. */
80 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
83 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
84 #elif defined __MINGW32__
85 if (u
->unit_number
== options
.stdin_unit
)
86 fstrcpy (iqp
->name
, iqp
->name_len
, "CONIN$", sizeof("CONIN$"));
87 else if (u
->unit_number
== options
.stdout_unit
)
88 fstrcpy (iqp
->name
, iqp
->name_len
, "CONOUT$", sizeof("CONOUT$"));
89 else if (u
->unit_number
== options
.stderr_unit
)
90 fstrcpy (iqp
->name
, iqp
->name_len
, "CONERR$", sizeof("CONERR$"));
92 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
94 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
98 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
103 switch (u
->flags
.access
)
105 case ACCESS_SEQUENTIAL
:
115 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
118 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
121 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
124 p
= inquire_sequential (NULL
, 0);
126 switch (u
->flags
.access
)
132 case ACCESS_SEQUENTIAL
:
136 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
139 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
142 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
145 p
= inquire_direct (NULL
, 0);
147 switch (u
->flags
.access
)
149 case ACCESS_SEQUENTIAL
:
157 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
160 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
163 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
168 switch (u
->flags
.form
)
173 case FORM_UNFORMATTED
:
177 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
180 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
183 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
186 p
= inquire_formatted (NULL
, 0);
188 switch (u
->flags
.form
)
193 case FORM_UNFORMATTED
:
197 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
200 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
203 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
206 p
= inquire_unformatted (NULL
, 0);
208 switch (u
->flags
.form
)
213 case FORM_UNFORMATTED
:
217 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
220 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
223 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
224 /* F2018 (N2137) 12.10.2.26: If there is no connection, recl is
225 assigned the value -1. */
226 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: -1;
228 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
229 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
231 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
233 /* This only makes sense in the context of DIRECT access. */
234 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
235 *iqp
->nextrec
= u
->last_record
+ 1;
240 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
242 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
245 switch (u
->flags
.blank
)
254 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
257 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
260 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
262 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
265 switch (u
->flags
.pad
)
274 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
277 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
280 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
282 GFC_INTEGER_4 cf2
= iqp
->flags2
;
284 if ((cf2
& IOPARM_INQUIRE_HAS_PENDING
) != 0)
287 if ((cf2
& IOPARM_INQUIRE_HAS_ID
) != 0)
290 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
292 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
295 switch (u
->flags
.encoding
)
297 case ENCODING_DEFAULT
:
304 internal_error (&iqp
->common
, "inquire_via_unit(): Bad encoding");
307 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, p
);
310 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
312 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
315 switch (u
->flags
.decimal
)
324 internal_error (&iqp
->common
, "inquire_via_unit(): Bad comma");
327 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, p
);
330 if ((cf2
& IOPARM_INQUIRE_HAS_ASYNCHRONOUS
) != 0)
335 switch (u
->flags
.async
)
344 internal_error (&iqp
->common
, "inquire_via_unit(): Bad async");
347 cf_strcpy (iqp
->asynchronous
, iqp
->asynchronous_len
, p
);
350 if ((cf2
& IOPARM_INQUIRE_HAS_SIGN
) != 0)
355 switch (u
->flags
.sign
)
357 case SIGN_PROCDEFINED
:
358 p
= "PROCESSOR_DEFINED";
367 internal_error (&iqp
->common
, "inquire_via_unit(): Bad sign");
370 cf_strcpy (iqp
->sign
, iqp
->sign_len
, p
);
373 if ((cf2
& IOPARM_INQUIRE_HAS_ROUND
) != 0)
378 switch (u
->flags
.round
)
392 case ROUND_COMPATIBLE
:
395 case ROUND_PROCDEFINED
:
396 p
= "PROCESSOR_DEFINED";
399 internal_error (&iqp
->common
, "inquire_via_unit(): Bad round");
402 cf_strcpy (iqp
->round
, iqp
->round_len
, p
);
405 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
412 *iqp
->size
= ssize (u
->s
);
416 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
421 switch (u
->flags
.access
)
423 case ACCESS_SEQUENTIAL
:
431 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
434 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, p
);
437 if ((cf2
& IOPARM_INQUIRE_HAS_SHARE
) != 0)
442 switch (u
->flags
.share
)
450 case SHARE_UNSPECIFIED
:
454 internal_error (&iqp
->common
,
455 "inquire_via_unit(): Bad share");
459 cf_strcpy (iqp
->share
, iqp
->share_len
, p
);
462 if ((cf2
& IOPARM_INQUIRE_HAS_CC
) != 0)
482 internal_error (&iqp
->common
, "inquire_via_unit(): Bad cc");
486 cf_strcpy (iqp
->cc
, iqp
->cc_len
, p
);
490 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
492 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
496 /* If the position is unspecified, check if we can figure
497 out whether it's at the beginning or end. */
498 if (u
->flags
.position
== POSITION_UNSPECIFIED
)
500 gfc_offset cur
= stell (u
->s
);
502 u
->flags
.position
= POSITION_REWIND
;
503 else if (cur
!= -1 && (ssize (u
->s
) == cur
))
504 u
->flags
.position
= POSITION_APPEND
;
506 switch (u
->flags
.position
)
508 case POSITION_REWIND
:
511 case POSITION_APPEND
:
518 /* If the position has changed and is not rewind or
519 append, it must be set to a processor-dependent
525 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
528 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
533 switch (u
->flags
.action
)
541 case ACTION_READWRITE
:
545 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
548 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
551 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
553 p
= (!u
|| u
->flags
.action
== ACTION_WRITE
) ? no
: yes
;
554 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
557 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
559 p
= (!u
|| u
->flags
.action
== ACTION_READ
) ? no
: yes
;
560 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
563 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
565 p
= (!u
|| u
->flags
.action
!= ACTION_READWRITE
) ? no
: yes
;
566 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
569 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
571 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
574 switch (u
->flags
.delim
)
577 case DELIM_UNSPECIFIED
:
583 case DELIM_APOSTROPHE
:
587 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
590 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
593 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
595 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
598 switch (u
->flags
.pad
)
607 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
610 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
613 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
618 switch (u
->flags
.convert
)
620 case GFC_CONVERT_NATIVE
:
621 p
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
624 case GFC_CONVERT_SWAP
:
625 p
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
629 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
632 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
637 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
638 only used if the filename is *not* connected to a unit number. */
641 inquire_via_filename (st_parameter_inquire
*iqp
)
644 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
646 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
647 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
649 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
652 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
655 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
658 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
659 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
661 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
662 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
664 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
667 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
670 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
673 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
676 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
677 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
679 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
682 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
685 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
688 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
691 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
694 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
697 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
698 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
700 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
701 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
703 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
705 GFC_INTEGER_4 cf2
= iqp
->flags2
;
707 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
708 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
710 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
711 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
713 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
714 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
716 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
717 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
719 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
720 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
722 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
723 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
725 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
726 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
728 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
729 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, "UNKNOWN");
731 if ((cf2
& IOPARM_INQUIRE_HAS_SHARE
) != 0)
732 cf_strcpy (iqp
->share
, iqp
->share_len
, "UNKNOWN");
734 if ((cf2
& IOPARM_INQUIRE_HAS_CC
) != 0)
735 cf_strcpy (iqp
->cc
, iqp
->cc_len
, "UNKNOWN");
738 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
739 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
741 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
742 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
744 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
746 p
= inquire_read (iqp
->file
, iqp
->file_len
);
747 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
750 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
752 p
= inquire_write (iqp
->file
, iqp
->file_len
);
753 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
756 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
758 p
= inquire_read (iqp
->file
, iqp
->file_len
);
759 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
764 /* Library entry point for the INQUIRE statement (non-IOLENGTH
767 extern void st_inquire (st_parameter_inquire
*);
768 export_proto(st_inquire
);
771 st_inquire (st_parameter_inquire
*iqp
)
775 library_start (&iqp
->common
);
777 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
779 u
= find_unit (iqp
->common
.unit
);
780 inquire_via_unit (iqp
, u
);
784 u
= find_file (iqp
->file
, iqp
->file_len
);
786 inquire_via_filename (iqp
);
788 inquire_via_unit (iqp
, u
);