OSDN Git Service

* g++.dg/cast.C: Change fields of structures to "long" to pass
[pf3gnuchains/gcc-fork.git] / libgfortran / io / inquire.c
1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009, 2010
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
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)
10 any later version.
11
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.
16
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.
20
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/>.  */
25
26
27 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
28
29 #include "io.h"
30 #include "unix.h"
31 #include <string.h>
32
33
34 static const char undefined[] = "UNDEFINED";
35
36
37 /* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */
38
39 static void
40 inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
41 {
42   const char *p;
43   GFC_INTEGER_4 cf = iqp->common.flags;
44
45   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
46     {
47       *iqp->exist = (iqp->common.unit >= 0
48                      && iqp->common.unit <= GFC_INTEGER_4_HUGE);
49
50       if ((cf & IOPARM_INQUIRE_HAS_FILE) == 0)
51         {
52           if (!(*iqp->exist))
53             *iqp->common.iostat = LIBERROR_BAD_UNIT;
54           *iqp->exist = *iqp->exist
55                         && (*iqp->common.iostat != LIBERROR_BAD_UNIT);
56         }
57     }
58
59   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
60     *iqp->opened = (u != NULL);
61
62   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
63     *iqp->number = (u != NULL) ? u->unit_number : -1;
64
65   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
66     *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
67
68   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
69       && u != NULL && u->flags.status != STATUS_SCRATCH)
70     {
71 #ifdef HAVE_TTYNAME
72       if (u->unit_number == options.stdin_unit
73           || u->unit_number == options.stdout_unit
74           || u->unit_number == options.stderr_unit)
75         {
76           char * tmp = ttyname (((unix_stream *) u->s)->fd);
77           if (tmp != NULL)
78             {
79               int tmplen = strlen (tmp);
80               fstrcpy (iqp->name, iqp->name_len, tmp, tmplen);
81             }
82           else /* If ttyname does not work, go with the default.  */
83             fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
84         }
85       else
86 #endif
87         fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
88     }
89
90   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
91     {
92       if (u == NULL)
93         p = undefined;
94       else
95         switch (u->flags.access)
96           {
97           case ACCESS_SEQUENTIAL:
98             p = "SEQUENTIAL";
99             break;
100           case ACCESS_DIRECT:
101             p = "DIRECT";
102             break;
103           case ACCESS_STREAM:
104             p = "STREAM";
105             break;
106           default:
107             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
108           }
109
110       cf_strcpy (iqp->access, iqp->access_len, p);
111     }
112
113   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
114     {
115       if (u == NULL)
116         p = inquire_sequential (NULL, 0);
117       else
118         switch (u->flags.access)
119           {
120           case ACCESS_DIRECT:
121           case ACCESS_STREAM:
122             p = "NO";
123             break;
124           case ACCESS_SEQUENTIAL:
125             p = "YES";
126             break;
127           default:
128             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
129           }
130
131       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
132     }
133
134   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
135     {
136       if (u == NULL)
137         p = inquire_direct (NULL, 0);
138       else
139         switch (u->flags.access)
140           {
141           case ACCESS_SEQUENTIAL:
142           case ACCESS_STREAM:
143             p = "NO";
144             break;
145           case ACCESS_DIRECT:
146             p = "YES";
147             break;
148           default:
149             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
150           }
151
152       cf_strcpy (iqp->direct, iqp->direct_len, p);
153     }
154
155   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
156     {
157       if (u == NULL)
158         p = undefined;
159       else
160         switch (u->flags.form)
161           {
162           case FORM_FORMATTED:
163             p = "FORMATTED";
164             break;
165           case FORM_UNFORMATTED:
166             p = "UNFORMATTED";
167             break;
168           default:
169             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
170           }
171
172       cf_strcpy (iqp->form, iqp->form_len, p);
173     }
174
175   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
176     {
177       if (u == NULL)
178         p = inquire_formatted (NULL, 0);
179       else
180         switch (u->flags.form)
181           {
182           case FORM_FORMATTED:
183             p = "YES";
184             break;
185           case FORM_UNFORMATTED:
186             p = "NO";
187             break;
188           default:
189             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
190           }
191
192       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
193     }
194
195   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
196     {
197       if (u == NULL)
198         p = inquire_unformatted (NULL, 0);
199       else
200         switch (u->flags.form)
201           {
202           case FORM_FORMATTED:
203             p = "NO";
204             break;
205           case FORM_UNFORMATTED:
206             p = "YES";
207             break;
208           default:
209             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
210           }
211
212       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
213     }
214
215   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
216     *iqp->recl_out = (u != NULL) ? u->recl : 0;
217
218   if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
219     *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0;
220
221   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
222     {
223       /* This only makes sense in the context of DIRECT access.  */
224       if (u != NULL && u->flags.access == ACCESS_DIRECT)
225         *iqp->nextrec = u->last_record + 1;
226       else
227         *iqp->nextrec = 0;
228     }
229
230   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
231     {
232       if (u == NULL || u->flags.form != FORM_FORMATTED)
233         p = undefined;
234       else
235         switch (u->flags.blank)
236           {
237           case BLANK_NULL:
238             p = "NULL";
239             break;
240           case BLANK_ZERO:
241             p = "ZERO";
242             break;
243           default:
244             internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
245           }
246
247       cf_strcpy (iqp->blank, iqp->blank_len, p);
248     }
249
250   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
251     {
252       if (u == NULL || u->flags.form != FORM_FORMATTED)
253         p = undefined;
254       else
255         switch (u->flags.pad)
256           {
257           case PAD_YES:
258             p = "YES";
259             break;
260           case PAD_NO:
261             p = "NO";
262             break;
263           default:
264             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
265           }
266
267       cf_strcpy (iqp->pad, iqp->pad_len, p);
268     }
269
270   if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
271     {
272       GFC_INTEGER_4 cf2 = iqp->flags2;
273
274       if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
275         *iqp->pending = 0;
276   
277       if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
278         *iqp->id = 0;
279
280       if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
281         {
282           if (u == NULL || u->flags.form != FORM_FORMATTED)
283             p = undefined;
284           else
285             switch (u->flags.encoding)
286               {
287               case ENCODING_DEFAULT:
288                 p = "UNKNOWN";
289                 break;
290               case ENCODING_UTF8:
291                 p = "UTF-8";
292                 break;
293               default:
294                 internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
295               }
296
297           cf_strcpy (iqp->encoding, iqp->encoding_len, p);
298         }
299
300       if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
301         {
302           if (u == NULL || u->flags.form != FORM_FORMATTED)
303             p = undefined;
304           else
305             switch (u->flags.decimal)
306               {
307               case DECIMAL_POINT:
308                 p = "POINT";
309                 break;
310               case DECIMAL_COMMA:
311                 p = "COMMA";
312                 break;
313               default:
314                 internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
315               }
316
317           cf_strcpy (iqp->decimal, iqp->decimal_len, p);
318         }
319
320       if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
321         {
322           if (u == NULL)
323             p = undefined;
324           else
325             switch (u->flags.async)
326             {
327               case ASYNC_YES:
328                 p = "YES";
329                 break;
330               case ASYNC_NO:
331                 p = "NO";
332                 break;
333               default:
334                 internal_error (&iqp->common, "inquire_via_unit(): Bad async");
335             }
336
337           cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
338         }
339
340       if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
341         {
342           if (u == NULL)
343             p = undefined;
344           else
345             switch (u->flags.sign)
346             {
347               case SIGN_PROCDEFINED:
348                 p = "PROCESSOR_DEFINED";
349                 break;
350               case SIGN_SUPPRESS:
351                 p = "SUPPRESS";
352                 break;
353               case SIGN_PLUS:
354                 p = "PLUS";
355                 break;
356               default:
357                 internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
358             }
359
360           cf_strcpy (iqp->sign, iqp->sign_len, p);
361         }
362
363       if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
364         {
365           if (u == NULL)
366             p = undefined;
367           else
368             switch (u->flags.round)
369             {
370               case ROUND_UP:
371                 p = "UP";
372                 break;
373               case ROUND_DOWN:
374                 p = "DOWN";
375                 break;
376               case ROUND_ZERO:
377                 p = "ZERO";
378                 break;
379               case ROUND_NEAREST:
380                 p = "NEAREST";
381                 break;
382               case ROUND_COMPATIBLE:
383                 p = "COMPATIBLE";
384                 break;
385               case ROUND_PROCDEFINED:
386                 p = "PROCESSOR_DEFINED";
387                 break;
388               default:
389                 internal_error (&iqp->common, "inquire_via_unit(): Bad round");
390             }
391
392           cf_strcpy (iqp->round, iqp->round_len, p);
393         }
394
395       if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
396         {
397           if (u == NULL)
398             *iqp->size = -1;
399           else
400             *iqp->size = file_size (u->file, (gfc_charlen_type) u->file_len);
401         }
402     }
403
404   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
405     {
406       if (u == NULL || u->flags.access == ACCESS_DIRECT)
407         p = undefined;
408       else
409         switch (u->flags.position)
410           {
411              case POSITION_REWIND:
412                p = "REWIND";
413                break;
414              case POSITION_APPEND:
415                p = "APPEND";
416                break;
417              case POSITION_ASIS:
418                p = "ASIS";
419                break;
420              default:
421                /* if not direct access, it must be
422                   either REWIND, APPEND, or ASIS.
423                   ASIS seems to be the best default */
424                p = "ASIS";
425                break;
426           }
427       cf_strcpy (iqp->position, iqp->position_len, p);
428     }
429
430   if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
431     {
432       if (u == NULL)
433         p = undefined;
434       else
435         switch (u->flags.action)
436           {
437           case ACTION_READ:
438             p = "READ";
439             break;
440           case ACTION_WRITE:
441             p = "WRITE";
442             break;
443           case ACTION_READWRITE:
444             p = "READWRITE";
445             break;
446           default:
447             internal_error (&iqp->common, "inquire_via_unit(): Bad action");
448           }
449
450       cf_strcpy (iqp->action, iqp->action_len, p);
451     }
452
453   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
454     {
455       p = (u == NULL) ? inquire_read (NULL, 0) :
456         inquire_read (u->file, u->file_len);
457
458       cf_strcpy (iqp->read, iqp->read_len, p);
459     }
460
461   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
462     {
463       p = (u == NULL) ? inquire_write (NULL, 0) :
464         inquire_write (u->file, u->file_len);
465
466       cf_strcpy (iqp->write, iqp->write_len, p);
467     }
468
469   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
470     {
471       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
472         inquire_readwrite (u->file, u->file_len);
473
474       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
475     }
476
477   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
478     {
479       if (u == NULL || u->flags.form != FORM_FORMATTED)
480         p = undefined;
481       else
482         switch (u->flags.delim)
483           {
484           case DELIM_NONE:
485             p = "NONE";
486             break;
487           case DELIM_QUOTE:
488             p = "QUOTE";
489             break;
490           case DELIM_APOSTROPHE:
491             p = "APOSTROPHE";
492             break;
493           default:
494             internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
495           }
496
497       cf_strcpy (iqp->delim, iqp->delim_len, p);
498     }
499
500   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
501     {
502       if (u == NULL || u->flags.form != FORM_FORMATTED)
503         p = undefined;
504       else
505         switch (u->flags.pad)
506           {
507           case PAD_NO:
508             p = "NO";
509             break;
510           case PAD_YES:
511             p = "YES";
512             break;
513           default:
514             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
515           }
516
517       cf_strcpy (iqp->pad, iqp->pad_len, p);
518     }
519  
520   if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
521     {
522       if (u == NULL)
523         p = undefined;
524       else
525         switch (u->flags.convert)
526           {
527             /*  big_endian is 0 for little-endian, 1 for big-endian.  */
528           case GFC_CONVERT_NATIVE:
529             p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
530             break;
531
532           case GFC_CONVERT_SWAP:
533             p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
534             break;
535
536           default:
537             internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
538           }
539
540       cf_strcpy (iqp->convert, iqp->convert_len, p);
541     }
542 }
543
544
545 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
546  * only used if the filename is *not* connected to a unit number. */
547
548 static void
549 inquire_via_filename (st_parameter_inquire *iqp)
550 {
551   const char *p;
552   GFC_INTEGER_4 cf = iqp->common.flags;
553
554   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
555     *iqp->exist = file_exists (iqp->file, iqp->file_len);
556
557   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
558     *iqp->opened = 0;
559
560   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
561     *iqp->number = -1;
562
563   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
564     *iqp->named = 1;
565
566   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
567     fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
568
569   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
570     cf_strcpy (iqp->access, iqp->access_len, undefined);
571
572   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
573     {
574       p = "UNKNOWN";
575       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
576     }
577
578   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
579     {
580       p = "UNKNOWN";
581       cf_strcpy (iqp->direct, iqp->direct_len, p);
582     }
583
584   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
585     cf_strcpy (iqp->form, iqp->form_len, undefined);
586
587   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
588     {
589       p = "UNKNOWN";
590       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
591     }
592
593   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
594     {
595       p = "UNKNOWN";
596       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
597     }
598
599   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
600     *iqp->recl_out = 0;
601
602   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
603     *iqp->nextrec = 0;
604
605   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
606     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
607
608   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
609     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
610
611   if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
612     {
613       GFC_INTEGER_4 cf2 = iqp->flags2;
614
615       if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
616         cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
617   
618       if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
619         cf_strcpy (iqp->delim, iqp->delim_len, undefined);
620
621       if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
622         cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
623
624       if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
625         cf_strcpy (iqp->delim, iqp->delim_len, undefined);
626
627       if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
628         cf_strcpy (iqp->pad, iqp->pad_len, undefined);
629   
630       if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
631         cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
632
633       if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0)
634         *iqp->size = file_size (iqp->file, iqp->file_len);
635     }
636
637   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
638     cf_strcpy (iqp->position, iqp->position_len, undefined);
639
640   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
641     cf_strcpy (iqp->access, iqp->access_len, undefined);
642
643   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
644     {
645       p = inquire_read (iqp->file, iqp->file_len);
646       cf_strcpy (iqp->read, iqp->read_len, p);
647     }
648
649   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
650     {
651       p = inquire_write (iqp->file, iqp->file_len);
652       cf_strcpy (iqp->write, iqp->write_len, p);
653     }
654
655   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
656     {
657       p = inquire_read (iqp->file, iqp->file_len);
658       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
659     }
660 }
661
662
663 /* Library entry point for the INQUIRE statement (non-IOLENGTH
664    form).  */
665
666 extern void st_inquire (st_parameter_inquire *);
667 export_proto(st_inquire);
668
669 void
670 st_inquire (st_parameter_inquire *iqp)
671 {
672   gfc_unit *u;
673
674   library_start (&iqp->common);
675
676   if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
677     {
678       u = find_unit (iqp->common.unit);
679       inquire_via_unit (iqp, u);
680     }
681   else
682     {
683       u = find_file (iqp->file, iqp->file_len);
684       if (u == NULL)
685         inquire_via_filename (iqp);
686       else
687         inquire_via_unit (iqp, u);
688     }
689   if (u != NULL)
690     unlock_unit (u);
691
692   library_end ();
693 }