2016-01-14 Edward Smith-Rowland <3dw4rd@verizon.net>
[official-gcc.git] / libgfortran / io / inquire.c
blobae5ba622592cd256c76afe6f169dfa2d7bfe2923
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)
9 any later version.
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 */
28 #include "io.h"
29 #include "unix.h"
30 #include <string.h>
33 static const char yes[] = "YES", no[] = "NO", undefined[] = "UNDEFINED";
36 /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
38 static void
39 inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
41 const char *p;
42 GFC_INTEGER_4 cf = iqp->common.flags;
44 if (iqp->common.unit == GFC_INTERNAL_UNIT)
45 generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL);
47 if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
48 *iqp->exist = (u != NULL) || (iqp->common.unit >= 0);
50 if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
51 *iqp->opened = (u != NULL);
53 if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
54 *iqp->number = (u != NULL) ? u->unit_number : -1;
56 if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
57 *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
59 if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
60 && u != NULL && u->flags.status != STATUS_SCRATCH)
62 #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME)
63 if (u->unit_number == options.stdin_unit
64 || u->unit_number == options.stdout_unit
65 || u->unit_number == options.stderr_unit)
67 int err = stream_ttyname (u->s, iqp->name, iqp->name_len);
68 if (err == 0)
70 gfc_charlen_type tmplen = strlen (iqp->name);
71 if (iqp->name_len > tmplen)
72 memset (&iqp->name[tmplen], ' ', iqp->name_len - tmplen);
74 else /* If ttyname does not work, go with the default. */
75 cf_strcpy (iqp->name, iqp->name_len, u->filename);
77 else
78 cf_strcpy (iqp->name, iqp->name_len, u->filename);
79 #elif defined __MINGW32__
80 if (u->unit_number == options.stdin_unit)
81 fstrcpy (iqp->name, iqp->name_len, "CONIN$", sizeof("CONIN$"));
82 else if (u->unit_number == options.stdout_unit)
83 fstrcpy (iqp->name, iqp->name_len, "CONOUT$", sizeof("CONOUT$"));
84 else if (u->unit_number == options.stderr_unit)
85 fstrcpy (iqp->name, iqp->name_len, "CONERR$", sizeof("CONERR$"));
86 else
87 cf_strcpy (iqp->name, iqp->name_len, u->filename);
88 #else
89 cf_strcpy (iqp->name, iqp->name_len, u->filename);
90 #endif
93 if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
95 if (u == NULL)
96 p = undefined;
97 else
98 switch (u->flags.access)
100 case ACCESS_SEQUENTIAL:
101 p = "SEQUENTIAL";
102 break;
103 case ACCESS_DIRECT:
104 p = "DIRECT";
105 break;
106 case ACCESS_STREAM:
107 p = "STREAM";
108 break;
109 default:
110 internal_error (&iqp->common, "inquire_via_unit(): Bad access");
113 cf_strcpy (iqp->access, iqp->access_len, p);
116 if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
118 if (u == NULL)
119 p = inquire_sequential (NULL, 0);
120 else
121 switch (u->flags.access)
123 case ACCESS_DIRECT:
124 case ACCESS_STREAM:
125 p = no;
126 break;
127 case ACCESS_SEQUENTIAL:
128 p = yes;
129 break;
130 default:
131 internal_error (&iqp->common, "inquire_via_unit(): Bad access");
134 cf_strcpy (iqp->sequential, iqp->sequential_len, p);
137 if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
139 if (u == NULL)
140 p = inquire_direct (NULL, 0);
141 else
142 switch (u->flags.access)
144 case ACCESS_SEQUENTIAL:
145 case ACCESS_STREAM:
146 p = no;
147 break;
148 case ACCESS_DIRECT:
149 p = yes;
150 break;
151 default:
152 internal_error (&iqp->common, "inquire_via_unit(): Bad access");
155 cf_strcpy (iqp->direct, iqp->direct_len, p);
158 if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
160 if (u == NULL)
161 p = undefined;
162 else
163 switch (u->flags.form)
165 case FORM_FORMATTED:
166 p = "FORMATTED";
167 break;
168 case FORM_UNFORMATTED:
169 p = "UNFORMATTED";
170 break;
171 default:
172 internal_error (&iqp->common, "inquire_via_unit(): Bad form");
175 cf_strcpy (iqp->form, iqp->form_len, p);
178 if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
180 if (u == NULL)
181 p = inquire_formatted (NULL, 0);
182 else
183 switch (u->flags.form)
185 case FORM_FORMATTED:
186 p = yes;
187 break;
188 case FORM_UNFORMATTED:
189 p = no;
190 break;
191 default:
192 internal_error (&iqp->common, "inquire_via_unit(): Bad form");
195 cf_strcpy (iqp->formatted, iqp->formatted_len, p);
198 if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
200 if (u == NULL)
201 p = inquire_unformatted (NULL, 0);
202 else
203 switch (u->flags.form)
205 case FORM_FORMATTED:
206 p = no;
207 break;
208 case FORM_UNFORMATTED:
209 p = yes;
210 break;
211 default:
212 internal_error (&iqp->common, "inquire_via_unit(): Bad form");
215 cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
218 if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
219 *iqp->recl_out = (u != NULL) ? u->recl : 0;
221 if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
222 *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0;
224 if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
226 /* This only makes sense in the context of DIRECT access. */
227 if (u != NULL && u->flags.access == ACCESS_DIRECT)
228 *iqp->nextrec = u->last_record + 1;
229 else
230 *iqp->nextrec = 0;
233 if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
235 if (u == NULL || u->flags.form != FORM_FORMATTED)
236 p = undefined;
237 else
238 switch (u->flags.blank)
240 case BLANK_NULL:
241 p = "NULL";
242 break;
243 case BLANK_ZERO:
244 p = "ZERO";
245 break;
246 default:
247 internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
250 cf_strcpy (iqp->blank, iqp->blank_len, p);
253 if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
255 if (u == NULL || u->flags.form != FORM_FORMATTED)
256 p = undefined;
257 else
258 switch (u->flags.pad)
260 case PAD_YES:
261 p = yes;
262 break;
263 case PAD_NO:
264 p = no;
265 break;
266 default:
267 internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
270 cf_strcpy (iqp->pad, iqp->pad_len, p);
273 if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
275 GFC_INTEGER_4 cf2 = iqp->flags2;
277 if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
278 *iqp->pending = 0;
280 if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
281 *iqp->id = 0;
283 if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
285 if (u == NULL || u->flags.form != FORM_FORMATTED)
286 p = undefined;
287 else
288 switch (u->flags.encoding)
290 case ENCODING_DEFAULT:
291 p = "UNKNOWN";
292 break;
293 case ENCODING_UTF8:
294 p = "UTF-8";
295 break;
296 default:
297 internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
300 cf_strcpy (iqp->encoding, iqp->encoding_len, p);
303 if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
305 if (u == NULL || u->flags.form != FORM_FORMATTED)
306 p = undefined;
307 else
308 switch (u->flags.decimal)
310 case DECIMAL_POINT:
311 p = "POINT";
312 break;
313 case DECIMAL_COMMA:
314 p = "COMMA";
315 break;
316 default:
317 internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
320 cf_strcpy (iqp->decimal, iqp->decimal_len, p);
323 if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
325 if (u == NULL)
326 p = undefined;
327 else
328 switch (u->flags.async)
330 case ASYNC_YES:
331 p = yes;
332 break;
333 case ASYNC_NO:
334 p = no;
335 break;
336 default:
337 internal_error (&iqp->common, "inquire_via_unit(): Bad async");
340 cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
343 if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
345 if (u == NULL)
346 p = undefined;
347 else
348 switch (u->flags.sign)
350 case SIGN_PROCDEFINED:
351 p = "PROCESSOR_DEFINED";
352 break;
353 case SIGN_SUPPRESS:
354 p = "SUPPRESS";
355 break;
356 case SIGN_PLUS:
357 p = "PLUS";
358 break;
359 default:
360 internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
363 cf_strcpy (iqp->sign, iqp->sign_len, p);
366 if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
368 if (u == NULL)
369 p = undefined;
370 else
371 switch (u->flags.round)
373 case ROUND_UP:
374 p = "UP";
375 break;
376 case ROUND_DOWN:
377 p = "DOWN";
378 break;
379 case ROUND_ZERO:
380 p = "ZERO";
381 break;
382 case ROUND_NEAREST:
383 p = "NEAREST";
384 break;
385 case ROUND_COMPATIBLE:
386 p = "COMPATIBLE";
387 break;
388 case ROUND_PROCDEFINED:
389 p = "PROCESSOR_DEFINED";
390 break;
391 default:
392 internal_error (&iqp->common, "inquire_via_unit(): Bad round");
395 cf_strcpy (iqp->round, iqp->round_len, p);
398 if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
400 if (u == NULL)
401 *iqp->size = -1;
402 else
404 sflush (u->s);
405 *iqp->size = ssize (u->s);
409 if ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0)
411 if (u == NULL)
412 p = "UNKNOWN";
413 else
414 switch (u->flags.access)
416 case ACCESS_SEQUENTIAL:
417 case ACCESS_DIRECT:
418 p = no;
419 break;
420 case ACCESS_STREAM:
421 p = yes;
422 break;
423 default:
424 internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
427 cf_strcpy (iqp->iqstream, iqp->iqstream_len, p);
431 if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
433 if (u == NULL || u->flags.access == ACCESS_DIRECT)
434 p = undefined;
435 else
437 /* If the position is unspecified, check if we can figure
438 out whether it's at the beginning or end. */
439 if (u->flags.position == POSITION_UNSPECIFIED)
441 gfc_offset cur = stell (u->s);
442 if (cur == 0)
443 u->flags.position = POSITION_REWIND;
444 else if (cur != -1 && (ssize (u->s) == cur))
445 u->flags.position = POSITION_APPEND;
447 switch (u->flags.position)
449 case POSITION_REWIND:
450 p = "REWIND";
451 break;
452 case POSITION_APPEND:
453 p = "APPEND";
454 break;
455 case POSITION_ASIS:
456 p = "ASIS";
457 break;
458 default:
459 /* If the position has changed and is not rewind or
460 append, it must be set to a processor-dependent
461 value. */
462 p = "UNSPECIFIED";
463 break;
466 cf_strcpy (iqp->position, iqp->position_len, p);
469 if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
471 if (u == NULL)
472 p = undefined;
473 else
474 switch (u->flags.action)
476 case ACTION_READ:
477 p = "READ";
478 break;
479 case ACTION_WRITE:
480 p = "WRITE";
481 break;
482 case ACTION_READWRITE:
483 p = "READWRITE";
484 break;
485 default:
486 internal_error (&iqp->common, "inquire_via_unit(): Bad action");
489 cf_strcpy (iqp->action, iqp->action_len, p);
492 if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
494 p = (!u || u->flags.action == ACTION_WRITE) ? no : yes;
495 cf_strcpy (iqp->read, iqp->read_len, p);
498 if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
500 p = (!u || u->flags.action == ACTION_READ) ? no : yes;
501 cf_strcpy (iqp->write, iqp->write_len, p);
504 if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
506 p = (!u || u->flags.action != ACTION_READWRITE) ? no : yes;
507 cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
510 if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
512 if (u == NULL || u->flags.form != FORM_FORMATTED)
513 p = undefined;
514 else
515 switch (u->flags.delim)
517 case DELIM_NONE:
518 case DELIM_UNSPECIFIED:
519 p = "NONE";
520 break;
521 case DELIM_QUOTE:
522 p = "QUOTE";
523 break;
524 case DELIM_APOSTROPHE:
525 p = "APOSTROPHE";
526 break;
527 default:
528 internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
531 cf_strcpy (iqp->delim, iqp->delim_len, p);
534 if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
536 if (u == NULL || u->flags.form != FORM_FORMATTED)
537 p = undefined;
538 else
539 switch (u->flags.pad)
541 case PAD_NO:
542 p = no;
543 break;
544 case PAD_YES:
545 p = yes;
546 break;
547 default:
548 internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
551 cf_strcpy (iqp->pad, iqp->pad_len, p);
554 if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
556 if (u == NULL)
557 p = undefined;
558 else
559 switch (u->flags.convert)
561 /* big_endian is 0 for little-endian, 1 for big-endian. */
562 case GFC_CONVERT_NATIVE:
563 p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
564 break;
566 case GFC_CONVERT_SWAP:
567 p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
568 break;
570 default:
571 internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
574 cf_strcpy (iqp->convert, iqp->convert_len, p);
579 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
580 * only used if the filename is *not* connected to a unit number. */
582 static void
583 inquire_via_filename (st_parameter_inquire *iqp)
585 const char *p;
586 GFC_INTEGER_4 cf = iqp->common.flags;
588 if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
589 *iqp->exist = file_exists (iqp->file, iqp->file_len);
591 if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
592 *iqp->opened = 0;
594 if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
595 *iqp->number = -1;
597 if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
598 *iqp->named = 1;
600 if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
601 fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
603 if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
604 cf_strcpy (iqp->access, iqp->access_len, undefined);
606 if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
608 p = "UNKNOWN";
609 cf_strcpy (iqp->sequential, iqp->sequential_len, p);
612 if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
614 p = "UNKNOWN";
615 cf_strcpy (iqp->direct, iqp->direct_len, p);
618 if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
619 cf_strcpy (iqp->form, iqp->form_len, undefined);
621 if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
623 p = "UNKNOWN";
624 cf_strcpy (iqp->formatted, iqp->formatted_len, p);
627 if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
629 p = "UNKNOWN";
630 cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
633 if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
634 *iqp->recl_out = 0;
636 if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
637 *iqp->nextrec = 0;
639 if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
640 cf_strcpy (iqp->blank, iqp->blank_len, undefined);
642 if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
643 cf_strcpy (iqp->pad, iqp->pad_len, undefined);
645 if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
647 GFC_INTEGER_4 cf2 = iqp->flags2;
649 if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
650 cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
652 if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
653 cf_strcpy (iqp->delim, iqp->delim_len, undefined);
655 if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
656 cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
658 if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
659 cf_strcpy (iqp->delim, iqp->delim_len, undefined);
661 if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
662 cf_strcpy (iqp->pad, iqp->pad_len, undefined);
664 if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
665 cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
667 if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
668 *iqp->size = file_size (iqp->file, iqp->file_len);
670 if ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0)
671 cf_strcpy (iqp->iqstream, iqp->iqstream_len, "UNKNOWN");
674 if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
675 cf_strcpy (iqp->position, iqp->position_len, undefined);
677 if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
678 cf_strcpy (iqp->access, iqp->access_len, undefined);
680 if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
682 p = inquire_read (iqp->file, iqp->file_len);
683 cf_strcpy (iqp->read, iqp->read_len, p);
686 if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
688 p = inquire_write (iqp->file, iqp->file_len);
689 cf_strcpy (iqp->write, iqp->write_len, p);
692 if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
694 p = inquire_read (iqp->file, iqp->file_len);
695 cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
700 /* Library entry point for the INQUIRE statement (non-IOLENGTH
701 form). */
703 extern void st_inquire (st_parameter_inquire *);
704 export_proto(st_inquire);
706 void
707 st_inquire (st_parameter_inquire *iqp)
709 gfc_unit *u;
711 library_start (&iqp->common);
713 if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
715 u = find_unit (iqp->common.unit);
716 inquire_via_unit (iqp, u);
718 else
720 u = find_file (iqp->file, iqp->file_len);
721 if (u == NULL)
722 inquire_via_filename (iqp);
723 else
724 inquire_via_unit (iqp, u);
726 if (u != NULL)
727 unlock_unit (u);
729 library_end ();