1 /* Copyright (C) 2002-2013 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 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 ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
46 *iqp
->exist
= (iqp
->common
.unit
>= 0
47 && iqp
->common
.unit
<= GFC_INTEGER_4_HUGE
);
49 if ((cf
& IOPARM_INQUIRE_HAS_FILE
) == 0)
52 *iqp
->common
.iostat
= LIBERROR_BAD_UNIT
;
53 *iqp
->exist
= *iqp
->exist
54 && (*iqp
->common
.iostat
!= LIBERROR_BAD_UNIT
);
58 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
59 *iqp
->opened
= (u
!= NULL
);
61 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
62 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
64 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
65 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
67 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
68 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
70 #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME)
71 if (u
->unit_number
== options
.stdin_unit
72 || u
->unit_number
== options
.stdout_unit
73 || u
->unit_number
== options
.stderr_unit
)
75 int err
= stream_ttyname (u
->s
, iqp
->name
, iqp
->name_len
);
78 gfc_charlen_type tmplen
= strlen (iqp
->name
);
79 if (iqp
->name_len
> tmplen
)
80 memset (&iqp
->name
[tmplen
], ' ', iqp
->name_len
- tmplen
);
82 else /* If ttyname does not work, go with the default. */
83 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
86 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
87 #elif defined __MINGW32__
88 if (u
->unit_number
== options
.stdin_unit
)
89 fstrcpy (iqp
->name
, iqp
->name_len
, "CONIN$", sizeof("CONIN$"));
90 else if (u
->unit_number
== options
.stdout_unit
)
91 fstrcpy (iqp
->name
, iqp
->name_len
, "CONOUT$", sizeof("CONOUT$"));
92 else if (u
->unit_number
== options
.stderr_unit
)
93 fstrcpy (iqp
->name
, iqp
->name_len
, "CONERR$", sizeof("CONERR$"));
95 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
97 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
101 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
106 switch (u
->flags
.access
)
108 case ACCESS_SEQUENTIAL
:
118 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
121 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
124 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
127 p
= inquire_sequential (NULL
, 0);
129 switch (u
->flags
.access
)
135 case ACCESS_SEQUENTIAL
:
139 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
142 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
145 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
148 p
= inquire_direct (NULL
, 0);
150 switch (u
->flags
.access
)
152 case ACCESS_SEQUENTIAL
:
160 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
163 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
166 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
171 switch (u
->flags
.form
)
176 case FORM_UNFORMATTED
:
180 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
183 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
186 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
189 p
= inquire_formatted (NULL
, 0);
191 switch (u
->flags
.form
)
196 case FORM_UNFORMATTED
:
200 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
203 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
206 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
209 p
= inquire_unformatted (NULL
, 0);
211 switch (u
->flags
.form
)
216 case FORM_UNFORMATTED
:
220 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
223 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
226 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
227 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: 0;
229 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
230 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
232 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
234 /* This only makes sense in the context of DIRECT access. */
235 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
236 *iqp
->nextrec
= u
->last_record
+ 1;
241 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
243 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
246 switch (u
->flags
.blank
)
255 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
258 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
261 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
263 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
266 switch (u
->flags
.pad
)
275 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
278 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
281 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
283 GFC_INTEGER_4 cf2
= iqp
->flags2
;
285 if ((cf2
& IOPARM_INQUIRE_HAS_PENDING
) != 0)
288 if ((cf2
& IOPARM_INQUIRE_HAS_ID
) != 0)
291 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
293 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
296 switch (u
->flags
.encoding
)
298 case ENCODING_DEFAULT
:
305 internal_error (&iqp
->common
, "inquire_via_unit(): Bad encoding");
308 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, p
);
311 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
313 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
316 switch (u
->flags
.decimal
)
325 internal_error (&iqp
->common
, "inquire_via_unit(): Bad comma");
328 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, p
);
331 if ((cf2
& IOPARM_INQUIRE_HAS_ASYNCHRONOUS
) != 0)
336 switch (u
->flags
.async
)
345 internal_error (&iqp
->common
, "inquire_via_unit(): Bad async");
348 cf_strcpy (iqp
->asynchronous
, iqp
->asynchronous_len
, p
);
351 if ((cf2
& IOPARM_INQUIRE_HAS_SIGN
) != 0)
356 switch (u
->flags
.sign
)
358 case SIGN_PROCDEFINED
:
359 p
= "PROCESSOR_DEFINED";
368 internal_error (&iqp
->common
, "inquire_via_unit(): Bad sign");
371 cf_strcpy (iqp
->sign
, iqp
->sign_len
, p
);
374 if ((cf2
& IOPARM_INQUIRE_HAS_ROUND
) != 0)
379 switch (u
->flags
.round
)
393 case ROUND_COMPATIBLE
:
396 case ROUND_PROCDEFINED
:
397 p
= "PROCESSOR_DEFINED";
400 internal_error (&iqp
->common
, "inquire_via_unit(): Bad round");
403 cf_strcpy (iqp
->round
, iqp
->round_len
, p
);
406 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
413 *iqp
->size
= ssize (u
->s
);
417 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
422 switch (u
->flags
.access
)
424 case ACCESS_SEQUENTIAL
:
432 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
435 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, p
);
439 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
441 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
445 /* If the position is unspecified, check if we can figure
446 out whether it's at the beginning or end. */
447 if (u
->flags
.position
== POSITION_UNSPECIFIED
)
449 gfc_offset cur
= stell (u
->s
);
451 u
->flags
.position
= POSITION_REWIND
;
452 else if (cur
!= -1 && (ssize (u
->s
) == cur
))
453 u
->flags
.position
= POSITION_APPEND
;
455 switch (u
->flags
.position
)
457 case POSITION_REWIND
:
460 case POSITION_APPEND
:
467 /* If the position has changed and is not rewind or
468 append, it must be set to a processor-dependent
474 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
477 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
482 switch (u
->flags
.action
)
490 case ACTION_READWRITE
:
494 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
497 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
500 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
502 p
= (u
== NULL
) ? inquire_read (NULL
, 0) :
503 inquire_read (u
->file
, u
->file_len
);
505 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
508 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
510 p
= (u
== NULL
) ? inquire_write (NULL
, 0) :
511 inquire_write (u
->file
, u
->file_len
);
513 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
516 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
518 p
= (u
== NULL
) ? inquire_readwrite (NULL
, 0) :
519 inquire_readwrite (u
->file
, u
->file_len
);
521 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
524 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
526 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
529 switch (u
->flags
.delim
)
537 case DELIM_APOSTROPHE
:
541 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
544 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
547 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
549 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
552 switch (u
->flags
.pad
)
561 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
564 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
567 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
572 switch (u
->flags
.convert
)
574 /* big_endian is 0 for little-endian, 1 for big-endian. */
575 case GFC_CONVERT_NATIVE
:
576 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
579 case GFC_CONVERT_SWAP
:
580 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
584 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
587 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
592 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
593 * only used if the filename is *not* connected to a unit number. */
596 inquire_via_filename (st_parameter_inquire
*iqp
)
599 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
601 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
602 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
604 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
607 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
610 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
613 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
614 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
616 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
617 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
619 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
622 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
625 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
628 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
631 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
632 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
634 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
637 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
640 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
643 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
646 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
649 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
652 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
653 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
655 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
656 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
658 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
660 GFC_INTEGER_4 cf2
= iqp
->flags2
;
662 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
663 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
665 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
666 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
668 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
669 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
671 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
672 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
674 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
675 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
677 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
678 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
680 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
681 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
683 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
684 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, "UNKNOWN");
687 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
688 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
690 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
691 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
693 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
695 p
= inquire_read (iqp
->file
, iqp
->file_len
);
696 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
699 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
701 p
= inquire_write (iqp
->file
, iqp
->file_len
);
702 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
705 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
707 p
= inquire_read (iqp
->file
, iqp
->file_len
);
708 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
713 /* Library entry point for the INQUIRE statement (non-IOLENGTH
716 extern void st_inquire (st_parameter_inquire
*);
717 export_proto(st_inquire
);
720 st_inquire (st_parameter_inquire
*iqp
)
724 library_start (&iqp
->common
);
726 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
728 u
= find_unit (iqp
->common
.unit
);
729 inquire_via_unit (iqp
, u
);
733 u
= find_file (iqp
->file
, iqp
->file_len
);
735 inquire_via_filename (iqp
);
737 inquire_via_unit (iqp
, u
);