OSDN Git Service

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