1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009, 2010, 2011
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
27 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
34 static const char undefined
[] = "UNDEFINED";
37 /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
40 inquire_via_unit (st_parameter_inquire
*iqp
, gfc_unit
* u
)
43 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
45 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
47 *iqp
->exist
= (iqp
->common
.unit
>= 0
48 && iqp
->common
.unit
<= GFC_INTEGER_4_HUGE
);
50 if ((cf
& IOPARM_INQUIRE_HAS_FILE
) == 0)
53 *iqp
->common
.iostat
= LIBERROR_BAD_UNIT
;
54 *iqp
->exist
= *iqp
->exist
55 && (*iqp
->common
.iostat
!= LIBERROR_BAD_UNIT
);
59 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
60 *iqp
->opened
= (u
!= NULL
);
62 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
63 *iqp
->number
= (u
!= NULL
) ? u
->unit_number
: -1;
65 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
66 *iqp
->named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
68 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0
69 && u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
71 #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME)
72 if (u
->unit_number
== options
.stdin_unit
73 || u
->unit_number
== options
.stdout_unit
74 || u
->unit_number
== options
.stderr_unit
)
76 int err
= stream_ttyname (u
->s
, iqp
->name
, iqp
->name_len
);
79 gfc_charlen_type tmplen
= strlen (iqp
->name
);
80 if (iqp
->name_len
> tmplen
)
81 memset (&iqp
->name
[tmplen
], ' ', iqp
->name_len
- tmplen
);
83 else /* If ttyname does not work, go with the default. */
84 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
87 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
88 #elif defined __MINGW32__
89 if (u
->unit_number
== options
.stdin_unit
)
90 fstrcpy (iqp
->name
, iqp
->name_len
, "CONIN$", sizeof("CONIN$"));
91 else if (u
->unit_number
== options
.stdout_unit
)
92 fstrcpy (iqp
->name
, iqp
->name_len
, "CONOUT$", sizeof("CONOUT$"));
93 else if (u
->unit_number
== options
.stderr_unit
)
94 fstrcpy (iqp
->name
, iqp
->name_len
, "CONERR$", sizeof("CONERR$"));
96 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
98 fstrcpy (iqp
->name
, iqp
->name_len
, u
->file
, u
->file_len
);
102 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
107 switch (u
->flags
.access
)
109 case ACCESS_SEQUENTIAL
:
119 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
122 cf_strcpy (iqp
->access
, iqp
->access_len
, p
);
125 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
128 p
= inquire_sequential (NULL
, 0);
130 switch (u
->flags
.access
)
136 case ACCESS_SEQUENTIAL
:
140 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
143 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
146 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
149 p
= inquire_direct (NULL
, 0);
151 switch (u
->flags
.access
)
153 case ACCESS_SEQUENTIAL
:
161 internal_error (&iqp
->common
, "inquire_via_unit(): Bad access");
164 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
167 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
172 switch (u
->flags
.form
)
177 case FORM_UNFORMATTED
:
181 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
184 cf_strcpy (iqp
->form
, iqp
->form_len
, p
);
187 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
190 p
= inquire_formatted (NULL
, 0);
192 switch (u
->flags
.form
)
197 case FORM_UNFORMATTED
:
201 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
204 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
207 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
210 p
= inquire_unformatted (NULL
, 0);
212 switch (u
->flags
.form
)
217 case FORM_UNFORMATTED
:
221 internal_error (&iqp
->common
, "inquire_via_unit(): Bad form");
224 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
227 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
228 *iqp
->recl_out
= (u
!= NULL
) ? u
->recl
: 0;
230 if ((cf
& IOPARM_INQUIRE_HAS_STRM_POS_OUT
) != 0)
231 *iqp
->strm_pos_out
= (u
!= NULL
) ? u
->strm_pos
: 0;
233 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
235 /* This only makes sense in the context of DIRECT access. */
236 if (u
!= NULL
&& u
->flags
.access
== ACCESS_DIRECT
)
237 *iqp
->nextrec
= u
->last_record
+ 1;
242 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
244 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
247 switch (u
->flags
.blank
)
256 internal_error (&iqp
->common
, "inquire_via_unit(): Bad blank");
259 cf_strcpy (iqp
->blank
, iqp
->blank_len
, p
);
262 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
264 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
267 switch (u
->flags
.pad
)
276 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
279 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
282 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
284 GFC_INTEGER_4 cf2
= iqp
->flags2
;
286 if ((cf2
& IOPARM_INQUIRE_HAS_PENDING
) != 0)
289 if ((cf2
& IOPARM_INQUIRE_HAS_ID
) != 0)
292 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
294 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
297 switch (u
->flags
.encoding
)
299 case ENCODING_DEFAULT
:
306 internal_error (&iqp
->common
, "inquire_via_unit(): Bad encoding");
309 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, p
);
312 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
314 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
317 switch (u
->flags
.decimal
)
326 internal_error (&iqp
->common
, "inquire_via_unit(): Bad comma");
329 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, p
);
332 if ((cf2
& IOPARM_INQUIRE_HAS_ASYNCHRONOUS
) != 0)
337 switch (u
->flags
.async
)
346 internal_error (&iqp
->common
, "inquire_via_unit(): Bad async");
349 cf_strcpy (iqp
->asynchronous
, iqp
->asynchronous_len
, p
);
352 if ((cf2
& IOPARM_INQUIRE_HAS_SIGN
) != 0)
357 switch (u
->flags
.sign
)
359 case SIGN_PROCDEFINED
:
360 p
= "PROCESSOR_DEFINED";
369 internal_error (&iqp
->common
, "inquire_via_unit(): Bad sign");
372 cf_strcpy (iqp
->sign
, iqp
->sign_len
, p
);
375 if ((cf2
& IOPARM_INQUIRE_HAS_ROUND
) != 0)
380 switch (u
->flags
.round
)
394 case ROUND_COMPATIBLE
:
397 case ROUND_PROCDEFINED
:
398 p
= "PROCESSOR_DEFINED";
401 internal_error (&iqp
->common
, "inquire_via_unit(): Bad round");
404 cf_strcpy (iqp
->round
, iqp
->round_len
, p
);
407 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
412 *iqp
->size
= file_size (u
->file
, (gfc_charlen_type
) u
->file_len
);
416 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
418 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
421 switch (u
->flags
.position
)
423 case POSITION_REWIND
:
426 case POSITION_APPEND
:
433 /* if not direct access, it must be
434 either REWIND, APPEND, or ASIS.
435 ASIS seems to be the best default */
439 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
442 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
447 switch (u
->flags
.action
)
455 case ACTION_READWRITE
:
459 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
462 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
465 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
467 p
= (u
== NULL
) ? inquire_read (NULL
, 0) :
468 inquire_read (u
->file
, u
->file_len
);
470 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
473 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
475 p
= (u
== NULL
) ? inquire_write (NULL
, 0) :
476 inquire_write (u
->file
, u
->file_len
);
478 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
481 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
483 p
= (u
== NULL
) ? inquire_readwrite (NULL
, 0) :
484 inquire_readwrite (u
->file
, u
->file_len
);
486 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
489 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
491 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
494 switch (u
->flags
.delim
)
502 case DELIM_APOSTROPHE
:
506 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
509 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
512 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
514 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
517 switch (u
->flags
.pad
)
526 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
529 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
532 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
537 switch (u
->flags
.convert
)
539 /* big_endian is 0 for little-endian, 1 for big-endian. */
540 case GFC_CONVERT_NATIVE
:
541 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
544 case GFC_CONVERT_SWAP
:
545 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
549 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
552 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
557 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
558 * only used if the filename is *not* connected to a unit number. */
561 inquire_via_filename (st_parameter_inquire
*iqp
)
564 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
566 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
567 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
569 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
572 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
575 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
578 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
579 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
581 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
582 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
584 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
587 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
590 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
593 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
596 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
597 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
599 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
602 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
605 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
608 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
611 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
614 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
617 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
618 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
620 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
621 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
623 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
625 GFC_INTEGER_4 cf2
= iqp
->flags2
;
627 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
628 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
630 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
631 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
633 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
634 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
636 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
637 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
639 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
640 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
642 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
643 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
645 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
646 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
649 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
650 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
652 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
653 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
655 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
657 p
= inquire_read (iqp
->file
, iqp
->file_len
);
658 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
661 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
663 p
= inquire_write (iqp
->file
, iqp
->file_len
);
664 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
667 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
669 p
= inquire_read (iqp
->file
, iqp
->file_len
);
670 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
675 /* Library entry point for the INQUIRE statement (non-IOLENGTH
678 extern void st_inquire (st_parameter_inquire
*);
679 export_proto(st_inquire
);
682 st_inquire (st_parameter_inquire
*iqp
)
686 library_start (&iqp
->common
);
688 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
690 u
= find_unit (iqp
->common
.unit
);
691 inquire_via_unit (iqp
, u
);
695 u
= find_file (iqp
->file
, iqp
->file_len
);
697 inquire_via_filename (iqp
);
699 inquire_via_unit (iqp
, u
);