1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 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
)
72 if (u
->unit_number
== options
.stdin_unit
73 || u
->unit_number
== options
.stdout_unit
74 || u
->unit_number
== options
.stderr_unit
)
76 char * tmp
= ttyname (((unix_stream
*) u
->s
)->fd
);
79 int tmplen
= strlen (tmp
);
80 fstrcpy (iqp
->name
, iqp
->name_len
, tmp
, 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)
411 *iqp
->size
= file_size (u
->file
, (gfc_charlen_type
) u
->file_len
);
415 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
417 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
420 switch (u
->flags
.position
)
422 case POSITION_REWIND
:
425 case POSITION_APPEND
:
432 /* if not direct access, it must be
433 either REWIND, APPEND, or ASIS.
434 ASIS seems to be the best default */
438 cf_strcpy (iqp
->position
, iqp
->position_len
, p
);
441 if ((cf
& IOPARM_INQUIRE_HAS_ACTION
) != 0)
446 switch (u
->flags
.action
)
454 case ACTION_READWRITE
:
458 internal_error (&iqp
->common
, "inquire_via_unit(): Bad action");
461 cf_strcpy (iqp
->action
, iqp
->action_len
, p
);
464 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
466 p
= (u
== NULL
) ? inquire_read (NULL
, 0) :
467 inquire_read (u
->file
, u
->file_len
);
469 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
472 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
474 p
= (u
== NULL
) ? inquire_write (NULL
, 0) :
475 inquire_write (u
->file
, u
->file_len
);
477 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
480 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
482 p
= (u
== NULL
) ? inquire_readwrite (NULL
, 0) :
483 inquire_readwrite (u
->file
, u
->file_len
);
485 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
488 if ((cf
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
490 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
493 switch (u
->flags
.delim
)
501 case DELIM_APOSTROPHE
:
505 internal_error (&iqp
->common
, "inquire_via_unit(): Bad delim");
508 cf_strcpy (iqp
->delim
, iqp
->delim_len
, p
);
511 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
513 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
516 switch (u
->flags
.pad
)
525 internal_error (&iqp
->common
, "inquire_via_unit(): Bad pad");
528 cf_strcpy (iqp
->pad
, iqp
->pad_len
, p
);
531 if ((cf
& IOPARM_INQUIRE_HAS_CONVERT
) != 0)
536 switch (u
->flags
.convert
)
538 /* big_endian is 0 for little-endian, 1 for big-endian. */
539 case GFC_CONVERT_NATIVE
:
540 p
= big_endian
? "BIG_ENDIAN" : "LITTLE_ENDIAN";
543 case GFC_CONVERT_SWAP
:
544 p
= big_endian
? "LITTLE_ENDIAN" : "BIG_ENDIAN";
548 internal_error (&iqp
->common
, "inquire_via_unit(): Bad convert");
551 cf_strcpy (iqp
->convert
, iqp
->convert_len
, p
);
556 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
557 * only used if the filename is *not* connected to a unit number. */
560 inquire_via_filename (st_parameter_inquire
*iqp
)
563 GFC_INTEGER_4 cf
= iqp
->common
.flags
;
565 if ((cf
& IOPARM_INQUIRE_HAS_EXIST
) != 0)
566 *iqp
->exist
= file_exists (iqp
->file
, iqp
->file_len
);
568 if ((cf
& IOPARM_INQUIRE_HAS_OPENED
) != 0)
571 if ((cf
& IOPARM_INQUIRE_HAS_NUMBER
) != 0)
574 if ((cf
& IOPARM_INQUIRE_HAS_NAMED
) != 0)
577 if ((cf
& IOPARM_INQUIRE_HAS_NAME
) != 0)
578 fstrcpy (iqp
->name
, iqp
->name_len
, iqp
->file
, iqp
->file_len
);
580 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
581 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
583 if ((cf
& IOPARM_INQUIRE_HAS_SEQUENTIAL
) != 0)
586 cf_strcpy (iqp
->sequential
, iqp
->sequential_len
, p
);
589 if ((cf
& IOPARM_INQUIRE_HAS_DIRECT
) != 0)
592 cf_strcpy (iqp
->direct
, iqp
->direct_len
, p
);
595 if ((cf
& IOPARM_INQUIRE_HAS_FORM
) != 0)
596 cf_strcpy (iqp
->form
, iqp
->form_len
, undefined
);
598 if ((cf
& IOPARM_INQUIRE_HAS_FORMATTED
) != 0)
601 cf_strcpy (iqp
->formatted
, iqp
->formatted_len
, p
);
604 if ((cf
& IOPARM_INQUIRE_HAS_UNFORMATTED
) != 0)
607 cf_strcpy (iqp
->unformatted
, iqp
->unformatted_len
, p
);
610 if ((cf
& IOPARM_INQUIRE_HAS_RECL_OUT
) != 0)
613 if ((cf
& IOPARM_INQUIRE_HAS_NEXTREC
) != 0)
616 if ((cf
& IOPARM_INQUIRE_HAS_BLANK
) != 0)
617 cf_strcpy (iqp
->blank
, iqp
->blank_len
, undefined
);
619 if ((cf
& IOPARM_INQUIRE_HAS_PAD
) != 0)
620 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
622 if (cf
& IOPARM_INQUIRE_HAS_FLAGS2
)
624 GFC_INTEGER_4 cf2
= iqp
->flags2
;
626 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
627 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
629 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
630 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
632 if ((cf2
& IOPARM_INQUIRE_HAS_DECIMAL
) != 0)
633 cf_strcpy (iqp
->decimal
, iqp
->decimal_len
, undefined
);
635 if ((cf2
& IOPARM_INQUIRE_HAS_DELIM
) != 0)
636 cf_strcpy (iqp
->delim
, iqp
->delim_len
, undefined
);
638 if ((cf2
& IOPARM_INQUIRE_HAS_PAD
) != 0)
639 cf_strcpy (iqp
->pad
, iqp
->pad_len
, undefined
);
641 if ((cf2
& IOPARM_INQUIRE_HAS_ENCODING
) != 0)
642 cf_strcpy (iqp
->encoding
, iqp
->encoding_len
, undefined
);
644 if ((cf2
& IOPARM_INQUIRE_HAS_SIZE
) != 0)
645 *iqp
->size
= file_size (iqp
->file
, iqp
->file_len
);
648 if ((cf
& IOPARM_INQUIRE_HAS_POSITION
) != 0)
649 cf_strcpy (iqp
->position
, iqp
->position_len
, undefined
);
651 if ((cf
& IOPARM_INQUIRE_HAS_ACCESS
) != 0)
652 cf_strcpy (iqp
->access
, iqp
->access_len
, undefined
);
654 if ((cf
& IOPARM_INQUIRE_HAS_READ
) != 0)
656 p
= inquire_read (iqp
->file
, iqp
->file_len
);
657 cf_strcpy (iqp
->read
, iqp
->read_len
, p
);
660 if ((cf
& IOPARM_INQUIRE_HAS_WRITE
) != 0)
662 p
= inquire_write (iqp
->file
, iqp
->file_len
);
663 cf_strcpy (iqp
->write
, iqp
->write_len
, p
);
666 if ((cf
& IOPARM_INQUIRE_HAS_READWRITE
) != 0)
668 p
= inquire_read (iqp
->file
, iqp
->file_len
);
669 cf_strcpy (iqp
->readwrite
, iqp
->readwrite_len
, p
);
674 /* Library entry point for the INQUIRE statement (non-IOLENGTH
677 extern void st_inquire (st_parameter_inquire
*);
678 export_proto(st_inquire
);
681 st_inquire (st_parameter_inquire
*iqp
)
685 library_start (&iqp
->common
);
687 if ((iqp
->common
.flags
& IOPARM_INQUIRE_HAS_FILE
) == 0)
689 u
= find_unit (iqp
->common
.unit
);
690 inquire_via_unit (iqp
, u
);
694 u
= find_file (iqp
->file
, iqp
->file_len
);
696 inquire_via_filename (iqp
);
698 inquire_via_unit (iqp
, u
);