1 /* Copyright (C) 2002-2016 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 generate_error (&iqp
->common
, LIBERROR_INQUIRE_INTERNAL_UNIT
, NULL
);
47 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
48 *iqp
->exist
= (u
!= NULL
) || (iqp
->common
.unit
>= 0);
50 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
51 *iqp
->opened
= (u
!= NULL
);
53 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
54 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
56 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
57 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
59 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
60 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
62 #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME)
63 if (u
->unit_number
== options
.stdin_unit
64 || u
->unit_number
== options
.stdout_unit
65 || u
->unit_number
== options
.stderr_unit
)
67 int err
= stream_ttyname (u
->s
, iqp
->name
, iqp
->name_len
);
70 gfc_charlen_type tmplen
= strlen (iqp
->name
);
71 if (iqp
->name_len
> tmplen
)
72 memset (&iqp
->name
[tmplen
], ' ', iqp
->name_len
- tmplen
);
74 else /* If ttyname does not work, go with the default. */
75 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
78 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
79 #elif defined __MINGW32__
80 if (u
->unit_number
== options
.stdin_unit
)
81 fstrcpy (iqp
->name
, iqp
->name_len
, "CONIN$", sizeof("CONIN$"));
82 else if (u
->unit_number
== options
.stdout_unit
)
83 fstrcpy (iqp
->name
, iqp
->name_len
, "CONOUT$", sizeof("CONOUT$"));
84 else if (u
->unit_number
== options
.stderr_unit
)
85 fstrcpy (iqp
->name
, iqp
->name_len
, "CONERR$", sizeof("CONERR$"));
87 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
89 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
93 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
98 switch (u
->flags
.access
)
100 case ACCESS_SEQUENTIAL
:
110 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
113 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
116 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
119 p
= inquire_sequential (NULL
, 0);
121 switch (u
->flags
.access
)
127 case ACCESS_SEQUENTIAL
:
131 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
134 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
137 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
140 p
= inquire_direct (NULL
, 0);
142 switch (u
->flags
.access
)
144 case ACCESS_SEQUENTIAL
:
152 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
155 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
158 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
163 switch (u
->flags
.form
)
168 case FORM_UNFORMATTED
:
172 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
175 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
178 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
181 p
= inquire_formatted (NULL
, 0);
183 switch (u
->flags
.form
)
188 case FORM_UNFORMATTED
:
192 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
195 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
198 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
201 p
= inquire_unformatted (NULL
, 0);
203 switch (u
->flags
.form
)
208 case FORM_UNFORMATTED
:
212 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
215 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
218 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
219 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: 0;
221 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
222 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
224 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
226 /* This only makes sense in the context of DIRECT access. */
227 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
228 *iqp
->nextrec
= u
->last_record
+ 1;
233 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
235 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
238 switch (u
->flags
.blank
)
247 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
250 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
253 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
255 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
258 switch (u
->flags
.pad
)
267 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
270 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
273 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
275 GFC_INTEGER_4 cf2
= iqp
->flags2
;
277 if ((cf2
& IOPARM_INQUIRE_HAS_PENDING
) != 0)
280 if ((cf2
& IOPARM_INQUIRE_HAS_ID
) != 0)
283 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
285 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
288 switch (u
->flags
.encoding
)
290 case ENCODING_DEFAULT
:
297 internal_error (&iqp
->common
, "inquire_via_unit(): Bad encoding");
300 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, p
);
303 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
305 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
308 switch (u
->flags
.decimal
)
317 internal_error (&iqp
->common
, "inquire_via_unit(): Bad comma");
320 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, p
);
323 if ((cf2
& IOPARM_INQUIRE_HAS_ASYNCHRONOUS
) != 0)
328 switch (u
->flags
.async
)
337 internal_error (&iqp
->common
, "inquire_via_unit(): Bad async");
340 cf_strcpy (iqp
->asynchronous
, iqp
->asynchronous_len
, p
);
343 if ((cf2
& IOPARM_INQUIRE_HAS_SIGN
) != 0)
348 switch (u
->flags
.sign
)
350 case SIGN_PROCDEFINED
:
351 p
= "PROCESSOR_DEFINED";
360 internal_error (&iqp
->common
, "inquire_via_unit(): Bad sign");
363 cf_strcpy (iqp
->sign
, iqp
->sign_len
, p
);
366 if ((cf2
& IOPARM_INQUIRE_HAS_ROUND
) != 0)
371 switch (u
->flags
.round
)
385 case ROUND_COMPATIBLE
:
388 case ROUND_PROCDEFINED
:
389 p
= "PROCESSOR_DEFINED";
392 internal_error (&iqp
->common
, "inquire_via_unit(): Bad round");
395 cf_strcpy (iqp
->round
, iqp
->round_len
, p
);
398 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
405 *iqp
->size
= ssize (u
->s
);
409 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
414 switch (u
->flags
.access
)
416 case ACCESS_SEQUENTIAL
:
424 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
427 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, p
);
431 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
433 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
437 /* If the position is unspecified, check if we can figure
438 out whether it's at the beginning or end. */
439 if (u
->flags
.position
== POSITION_UNSPECIFIED
)
441 gfc_offset cur
= stell (u
->s
);
443 u
->flags
.position
= POSITION_REWIND
;
444 else if (cur
!= -1 && (ssize (u
->s
) == cur
))
445 u
->flags
.position
= POSITION_APPEND
;
447 switch (u
->flags
.position
)
449 case POSITION_REWIND
:
452 case POSITION_APPEND
:
459 /* If the position has changed and is not rewind or
460 append, it must be set to a processor-dependent
466 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
469 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
474 switch (u
->flags
.action
)
482 case ACTION_READWRITE
:
486 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
489 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
492 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
494 p
= (!u
|| u
->flags
.action
== ACTION_WRITE
) ? no
: yes
;
495 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
498 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
500 p
= (!u
|| u
->flags
.action
== ACTION_READ
) ? no
: yes
;
501 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
504 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
506 p
= (!u
|| u
->flags
.action
!= ACTION_READWRITE
) ? no
: yes
;
507 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
510 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
512 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
515 switch (u
->flags
.delim
)
518 case DELIM_UNSPECIFIED
:
524 case DELIM_APOSTROPHE
:
528 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
531 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
534 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
536 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
539 switch (u
->flags
.pad
)
548 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
551 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
554 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
559 switch (u
->flags
.convert
)
561 /* big_endian is 0 for little-endian, 1 for big-endian. */
562 case GFC_CONVERT_NATIVE
:
563 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
566 case GFC_CONVERT_SWAP
:
567 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
571 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
574 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
579 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
580 * only used if the filename is *not* connected to a unit number. */
583 inquire_via_filename (st_parameter_inquire
*iqp
)
586 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
588 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
589 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
591 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
594 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
597 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
600 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
601 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
603 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
604 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
606 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
609 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
612 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
615 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
618 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
619 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
621 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
624 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
627 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
630 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
633 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
636 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
639 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
640 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
642 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
643 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
645 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
647 GFC_INTEGER_4 cf2
= iqp
->flags2
;
649 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
650 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
652 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
653 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
655 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
656 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
658 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
659 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
661 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
662 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
664 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
665 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
667 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
668 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
670 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
671 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, "UNKNOWN");
674 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
675 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
677 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
678 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
680 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
682 p
= inquire_read (iqp
->file
, iqp
->file_len
);
683 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
686 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
688 p
= inquire_write (iqp
->file
, iqp
->file_len
);
689 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
692 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
694 p
= inquire_read (iqp
->file
, iqp
->file_len
);
695 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
700 /* Library entry point for the INQUIRE statement (non-IOLENGTH
703 extern void st_inquire (st_parameter_inquire
*);
704 export_proto(st_inquire
);
707 st_inquire (st_parameter_inquire
*iqp
)
711 library_start (&iqp
->common
);
713 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
715 u
= find_unit (iqp
->common
.unit
);
716 inquire_via_unit (iqp
, u
);
720 u
= find_file (iqp
->file
, iqp
->file_len
);
722 inquire_via_filename (iqp
);
724 inquire_via_unit (iqp
, u
);