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 iqp
->common
.unit
== GFC_INTERNAL_UNIT4
||
46 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
);
433 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
435 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
439 /* If the position is unspecified, check if we can figure
440 out whether it's at the beginning or end. */
441 if (u
->flags
.position
== POSITION_UNSPECIFIED
)
443 gfc_offset cur
= stell (u
->s
);
445 u
->flags
.position
= POSITION_REWIND
;
446 else if (cur
!= -1 && (ssize (u
->s
) == cur
))
447 u
->flags
.position
= POSITION_APPEND
;
449 switch (u
->flags
.position
)
451 case POSITION_REWIND
:
454 case POSITION_APPEND
:
461 /* If the position has changed and is not rewind or
462 append, it must be set to a processor-dependent
468 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
471 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
476 switch (u
->flags
.action
)
484 case ACTION_READWRITE
:
488 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
491 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
494 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
496 p
= (!u
|| u
->flags
.action
== ACTION_WRITE
) ? no
: yes
;
497 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
500 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
502 p
= (!u
|| u
->flags
.action
== ACTION_READ
) ? no
: yes
;
503 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
506 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
508 p
= (!u
|| u
->flags
.action
!= ACTION_READWRITE
) ? no
: yes
;
509 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
512 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
514 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
517 switch (u
->flags
.delim
)
520 case DELIM_UNSPECIFIED
:
526 case DELIM_APOSTROPHE
:
530 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
533 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
536 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
538 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
541 switch (u
->flags
.pad
)
550 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
553 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
556 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
561 switch (u
->flags
.convert
)
563 /* big_endian is 0 for little-endian, 1 for big-endian. */
564 case GFC_CONVERT_NATIVE
:
565 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
568 case GFC_CONVERT_SWAP
:
569 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
573 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
576 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
581 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
582 * only used if the filename is *not* connected to a unit number. */
585 inquire_via_filename (st_parameter_inquire
*iqp
)
588 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
590 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
591 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
593 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
596 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
599 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
602 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
603 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
605 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
606 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
608 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
611 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
614 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
617 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
620 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
621 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
623 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
626 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
629 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
632 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
635 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
638 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
641 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
642 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
644 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
645 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
647 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
649 GFC_INTEGER_4 cf2
= iqp
->flags2
;
651 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
652 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
654 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
655 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
657 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
658 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
660 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
661 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
663 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
664 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
666 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
667 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
669 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
670 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
672 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
673 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, "UNKNOWN");
676 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
677 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
679 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
680 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
682 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
684 p
= inquire_read (iqp
->file
, iqp
->file_len
);
685 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
688 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
690 p
= inquire_write (iqp
->file
, iqp
->file_len
);
691 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
694 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
696 p
= inquire_read (iqp
->file
, iqp
->file_len
);
697 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
702 /* Library entry point for the INQUIRE statement (non-IOLENGTH
705 extern void st_inquire (st_parameter_inquire
*);
706 export_proto(st_inquire
);
709 st_inquire (st_parameter_inquire
*iqp
)
713 library_start (&iqp
->common
);
715 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
717 u
= find_unit (iqp
->common
.unit
);
718 inquire_via_unit (iqp
, u
);
722 u
= find_file (iqp
->file
, iqp
->file_len
);
724 inquire_via_filename (iqp
);
726 inquire_via_unit (iqp
, u
);