OSDN Git Service

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