1 /* Copyright (C) 2002-2017 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
) || (iqp
->common
.unit
>= 0);
52 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
53 *iqp
->opened
= (u
!= NULL
);
55 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
56 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
58 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
59 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
61 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
62 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
64 #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME)
65 if (u
->unit_number
== options
.stdin_unit
66 || u
->unit_number
== options
.stdout_unit
67 || u
->unit_number
== options
.stderr_unit
)
69 int err
= stream_ttyname (u
->s
, iqp
->name
, iqp
->name_len
);
72 gfc_charlen_type tmplen
= strlen (iqp
->name
);
73 if (iqp
->name_len
> tmplen
)
74 memset (&iqp
->name
[tmplen
], ' ', iqp
->name_len
- tmplen
);
76 else /* If ttyname does not work, go with the default. */
77 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
80 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
81 #elif defined __MINGW32__
82 if (u
->unit_number
== options
.stdin_unit
)
83 fstrcpy (iqp
->name
, iqp
->name_len
, "CONIN$", sizeof("CONIN$"));
84 else if (u
->unit_number
== options
.stdout_unit
)
85 fstrcpy (iqp
->name
, iqp
->name_len
, "CONOUT$", sizeof("CONOUT$"));
86 else if (u
->unit_number
== options
.stderr_unit
)
87 fstrcpy (iqp
->name
, iqp
->name_len
, "CONERR$", sizeof("CONERR$"));
89 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
91 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
95 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
100 switch (u
->flags
.access
)
102 case ACCESS_SEQUENTIAL
:
112 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
115 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
118 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
121 p
= inquire_sequential (NULL
, 0);
123 switch (u
->flags
.access
)
129 case ACCESS_SEQUENTIAL
:
133 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
136 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
139 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
142 p
= inquire_direct (NULL
, 0);
144 switch (u
->flags
.access
)
146 case ACCESS_SEQUENTIAL
:
154 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
157 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
160 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
165 switch (u
->flags
.form
)
170 case FORM_UNFORMATTED
:
174 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
177 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
180 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
183 p
= inquire_formatted (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
->formatted
, iqp
->formatted_len
, p
);
200 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
203 p
= inquire_unformatted (NULL
, 0);
205 switch (u
->flags
.form
)
210 case FORM_UNFORMATTED
:
214 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
217 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
220 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
221 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: 0;
223 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
224 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
226 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
228 /* This only makes sense in the context of DIRECT access. */
229 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
230 *iqp
->nextrec
= u
->last_record
+ 1;
235 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
237 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
240 switch (u
->flags
.blank
)
249 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
252 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
255 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
257 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
260 switch (u
->flags
.pad
)
269 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
272 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
275 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
277 GFC_INTEGER_4 cf2
= iqp
->flags2
;
279 if ((cf2
& IOPARM_INQUIRE_HAS_PENDING
) != 0)
282 if ((cf2
& IOPARM_INQUIRE_HAS_ID
) != 0)
285 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
287 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
290 switch (u
->flags
.encoding
)
292 case ENCODING_DEFAULT
:
299 internal_error (&iqp
->common
, "inquire_via_unit(): Bad encoding");
302 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, p
);
305 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
307 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
310 switch (u
->flags
.decimal
)
319 internal_error (&iqp
->common
, "inquire_via_unit(): Bad comma");
322 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, p
);
325 if ((cf2
& IOPARM_INQUIRE_HAS_ASYNCHRONOUS
) != 0)
330 switch (u
->flags
.async
)
339 internal_error (&iqp
->common
, "inquire_via_unit(): Bad async");
342 cf_strcpy (iqp
->asynchronous
, iqp
->asynchronous_len
, p
);
345 if ((cf2
& IOPARM_INQUIRE_HAS_SIGN
) != 0)
350 switch (u
->flags
.sign
)
352 case SIGN_PROCDEFINED
:
353 p
= "PROCESSOR_DEFINED";
362 internal_error (&iqp
->common
, "inquire_via_unit(): Bad sign");
365 cf_strcpy (iqp
->sign
, iqp
->sign_len
, p
);
368 if ((cf2
& IOPARM_INQUIRE_HAS_ROUND
) != 0)
373 switch (u
->flags
.round
)
387 case ROUND_COMPATIBLE
:
390 case ROUND_PROCDEFINED
:
391 p
= "PROCESSOR_DEFINED";
394 internal_error (&iqp
->common
, "inquire_via_unit(): Bad round");
397 cf_strcpy (iqp
->round
, iqp
->round_len
, p
);
400 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
407 *iqp
->size
= ssize (u
->s
);
411 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
416 switch (u
->flags
.access
)
418 case ACCESS_SEQUENTIAL
:
426 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
429 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, p
);
432 if ((cf2
& IOPARM_INQUIRE_HAS_SHARE
) != 0)
437 switch (u
->flags
.share
)
445 case SHARE_UNSPECIFIED
:
449 internal_error (&iqp
->common
,
450 "inquire_via_unit(): Bad share");
454 cf_strcpy (iqp
->share
, iqp
->share_len
, p
);
457 if ((cf2
& IOPARM_INQUIRE_HAS_CC
) != 0)
477 internal_error (&iqp
->common
, "inquire_via_unit(): Bad cc");
481 cf_strcpy (iqp
->cc
, iqp
->cc_len
, p
);
485 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
487 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
491 /* If the position is unspecified, check if we can figure
492 out whether it's at the beginning or end. */
493 if (u
->flags
.position
== POSITION_UNSPECIFIED
)
495 gfc_offset cur
= stell (u
->s
);
497 u
->flags
.position
= POSITION_REWIND
;
498 else if (cur
!= -1 && (ssize (u
->s
) == cur
))
499 u
->flags
.position
= POSITION_APPEND
;
501 switch (u
->flags
.position
)
503 case POSITION_REWIND
:
506 case POSITION_APPEND
:
513 /* If the position has changed and is not rewind or
514 append, it must be set to a processor-dependent
520 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
523 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
528 switch (u
->flags
.action
)
536 case ACTION_READWRITE
:
540 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
543 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
546 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
548 p
= (!u
|| u
->flags
.action
== ACTION_WRITE
) ? no
: yes
;
549 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
552 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
554 p
= (!u
|| u
->flags
.action
== ACTION_READ
) ? no
: yes
;
555 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
558 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
560 p
= (!u
|| u
->flags
.action
!= ACTION_READWRITE
) ? no
: yes
;
561 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
564 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
566 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
569 switch (u
->flags
.delim
)
572 case DELIM_UNSPECIFIED
:
578 case DELIM_APOSTROPHE
:
582 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
585 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
588 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
590 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
593 switch (u
->flags
.pad
)
602 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
605 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
608 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
613 switch (u
->flags
.convert
)
615 /* big_endian is 0 for little-endian, 1 for big-endian. */
616 case GFC_CONVERT_NATIVE
:
617 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
620 case GFC_CONVERT_SWAP
:
621 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
625 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
628 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
633 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
634 only used if the filename is *not* connected to a unit number. */
637 inquire_via_filename (st_parameter_inquire
*iqp
)
640 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
642 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
643 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
645 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
648 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
651 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
654 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
655 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
657 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
658 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
660 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
663 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
666 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
669 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
672 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
673 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
675 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
678 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
681 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
684 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
687 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
690 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
693 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
694 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
696 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
697 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
699 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
701 GFC_INTEGER_4 cf2
= iqp
->flags2
;
703 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
704 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
706 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
707 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
709 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
710 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
712 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
713 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
715 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
716 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
718 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
719 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
721 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
722 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
724 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
725 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, "UNKNOWN");
727 if ((cf2
& IOPARM_INQUIRE_HAS_SHARE
) != 0)
728 cf_strcpy (iqp
->share
, iqp
->share_len
, "UNKNOWN");
730 if ((cf2
& IOPARM_INQUIRE_HAS_CC
) != 0)
731 cf_strcpy (iqp
->cc
, iqp
->cc_len
, "UNKNOWN");
734 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
735 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
737 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
738 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
740 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
742 p
= inquire_read (iqp
->file
, iqp
->file_len
);
743 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
746 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
748 p
= inquire_write (iqp
->file
, iqp
->file_len
);
749 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
752 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
754 p
= inquire_read (iqp
->file
, iqp
->file_len
);
755 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
760 /* Library entry point for the INQUIRE statement (non-IOLENGTH
763 extern void st_inquire (st_parameter_inquire
*);
764 export_proto(st_inquire
);
767 st_inquire (st_parameter_inquire
*iqp
)
771 library_start (&iqp
->common
);
773 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
775 u
= find_unit (iqp
->common
.unit
);
776 inquire_via_unit (iqp
, u
);
780 u
= find_file (iqp
->file
, iqp
->file_len
);
782 inquire_via_filename (iqp
);
784 inquire_via_unit (iqp
, u
);