1 /* Copyright (C) 2002-2014 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 ((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 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
86 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
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 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
97 cf_strcpy (iqp
->name
, iqp
->name_len
, u
->filename
);
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
|| u
->flags
.action
== ACTION_WRITE
) ? no
: yes
;
503 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
506 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
508 p
= (!u
|| u
->flags
.action
== ACTION_READ
) ? no
: yes
;
509 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
512 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
514 p
= (!u
|| u
->flags
.action
!= ACTION_READWRITE
) ? no
: yes
;
515 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
518 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
520 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
523 switch (u
->flags
.delim
)
526 case DELIM_UNSPECIFIED
:
532 case DELIM_APOSTROPHE
:
536 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
539 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
542 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
544 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
547 switch (u
->flags
.pad
)
556 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
559 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
562 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
567 switch (u
->flags
.convert
)
569 /* big_endian is 0 for little-endian, 1 for big-endian. */
570 case GFC_CONVERT_NATIVE
:
571 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
574 case GFC_CONVERT_SWAP
:
575 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
579 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
582 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
587 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
588 * only used if the filename is *not* connected to a unit number. */
591 inquire_via_filename (st_parameter_inquire
*iqp
)
594 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
596 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
597 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
599 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
602 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
605 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
608 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
609 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
611 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
612 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
614 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
617 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
620 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
623 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
626 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
627 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
629 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
632 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
635 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
638 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
641 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
644 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
647 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
648 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
650 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
651 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
653 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
655 GFC_INTEGER_4 cf2
= iqp
->flags2
;
657 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
658 cf_strcpy (iqp
->encoding
, iqp
->encoding_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_DECIMAL
) != 0)
664 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
666 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
667 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
669 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
670 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
672 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
673 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
675 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
676 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
678 if ((cf2
& IOPARM_INQUIRE_HAS_IQSTREAM
) != 0)
679 cf_strcpy (iqp
->iqstream
, iqp
->iqstream_len
, "UNKNOWN");
682 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
683 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
685 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
686 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
688 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
690 p
= inquire_read (iqp
->file
, iqp
->file_len
);
691 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
694 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
696 p
= inquire_write (iqp
->file
, iqp
->file_len
);
697 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
700 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
702 p
= inquire_read (iqp
->file
, iqp
->file_len
);
703 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
708 /* Library entry point for the INQUIRE statement (non-IOLENGTH
711 extern void st_inquire (st_parameter_inquire
*);
712 export_proto(st_inquire
);
715 st_inquire (st_parameter_inquire
*iqp
)
719 library_start (&iqp
->common
);
721 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
723 u
= find_unit (iqp
->common
.unit
);
724 inquire_via_unit (iqp
, u
);
728 u
= find_file (iqp
->file
, iqp
->file_len
);
730 inquire_via_filename (iqp
);
732 inquire_via_unit (iqp
, u
);