OSDN Git Service

2006-08-15 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / inquire.c
1 /* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
5
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 2, or (at your option)
9 any later version.
10
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file.  (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
18 executable.)
19
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 GNU General Public License for more details.
24
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING.  If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA.  */
29
30
31 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
32
33 #include "config.h"
34 #include "libgfortran.h"
35 #include "io.h"
36
37
38 static const char undefined[] = "UNDEFINED";
39
40
41 /* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */
42
43 static void
44 inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
45 {
46   const char *p;
47   GFC_INTEGER_4 cf = iqp->common.flags;
48
49   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
50     *iqp->exist = iqp->common.unit >= 0;
51
52   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
53     *iqp->opened = (u != NULL);
54
55   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
56     *iqp->number = (u != NULL) ? u->unit_number : -1;
57
58   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
59     *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
60
61   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
62       && u != NULL && u->flags.status != STATUS_SCRATCH)
63     fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
64
65   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
66     {
67       if (u == NULL)
68         p = undefined;
69       else
70         switch (u->flags.access)
71           {
72           case ACCESS_SEQUENTIAL:
73             p = "SEQUENTIAL";
74             break;
75           case ACCESS_DIRECT:
76             p = "DIRECT";
77             break;
78           case ACCESS_STREAM:
79             p = "STREAM";
80             break;
81           default:
82             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
83           }
84
85       cf_strcpy (iqp->access, iqp->access_len, p);
86     }
87
88   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
89     {
90       if (u == NULL)
91         p = inquire_sequential (NULL, 0);
92       else
93         {
94           /* disallow an open direct access file to be accessed sequentially */
95           if (u->flags.access == ACCESS_DIRECT)
96             p = "NO";
97           else   
98             p = inquire_sequential (u->file, u->file_len);
99         }
100
101       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
102     }
103
104   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
105     {
106       p = (u == NULL) ? inquire_direct (NULL, 0) :
107         inquire_direct (u->file, u->file_len);
108
109       cf_strcpy (iqp->direct, iqp->direct_len, p);
110     }
111
112   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
113     {
114       if (u == NULL)
115         p = undefined;
116       else
117         switch (u->flags.form)
118           {
119           case FORM_FORMATTED:
120             p = "FORMATTED";
121             break;
122           case FORM_UNFORMATTED:
123             p = "UNFORMATTED";
124             break;
125           default:
126             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
127           }
128
129       cf_strcpy (iqp->form, iqp->form_len, p);
130     }
131
132   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
133     {
134       p = (u == NULL) ? inquire_formatted (NULL, 0) :
135         inquire_formatted (u->file, u->file_len);
136
137       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
138     }
139
140   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
141     {
142       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
143         inquire_unformatted (u->file, u->file_len);
144
145       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
146     }
147
148   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
149     *iqp->recl_out = (u != NULL) ? u->recl : 0;
150
151   if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
152     *iqp->strm_pos_out = (u != NULL) ? u->last_record : 0;
153
154   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
155     *iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0;
156
157   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
158     {
159       if (u == NULL)
160         p = undefined;
161       else
162         switch (u->flags.blank)
163           {
164           case BLANK_NULL:
165             p = "NULL";
166             break;
167           case BLANK_ZERO:
168             p = "ZERO";
169             break;
170           default:
171             internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
172           }
173
174       cf_strcpy (iqp->blank, iqp->blank_len, p);
175     }
176
177   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
178     {
179       if (u == NULL || u->flags.access == ACCESS_DIRECT)
180         p = undefined;
181       else
182         switch (u->flags.position)
183           {
184              case POSITION_REWIND:
185                p = "REWIND";
186                break;
187              case POSITION_APPEND:
188                p = "APPEND";
189                break;
190              case POSITION_ASIS:
191                p = "ASIS";
192                break;
193              default:
194                /* if not direct access, it must be
195                   either REWIND, APPEND, or ASIS.
196                   ASIS seems to be the best default */
197                p = "ASIS";
198                break;
199           }
200       cf_strcpy (iqp->position, iqp->position_len, p);
201     }
202
203   if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
204     {
205       if (u == NULL)
206         p = undefined;
207       else
208         switch (u->flags.action)
209           {
210           case ACTION_READ:
211             p = "READ";
212             break;
213           case ACTION_WRITE:
214             p = "WRITE";
215             break;
216           case ACTION_READWRITE:
217             p = "READWRITE";
218             break;
219           default:
220             internal_error (&iqp->common, "inquire_via_unit(): Bad action");
221           }
222
223       cf_strcpy (iqp->action, iqp->action_len, p);
224     }
225
226   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
227     {
228       p = (u == NULL) ? inquire_read (NULL, 0) :
229         inquire_read (u->file, u->file_len);
230
231       cf_strcpy (iqp->read, iqp->read_len, p);
232     }
233
234   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
235     {
236       p = (u == NULL) ? inquire_write (NULL, 0) :
237         inquire_write (u->file, u->file_len);
238
239       cf_strcpy (iqp->write, iqp->write_len, p);
240     }
241
242   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
243     {
244       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
245         inquire_readwrite (u->file, u->file_len);
246
247       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
248     }
249
250   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
251     {
252       if (u == NULL || u->flags.form != FORM_FORMATTED)
253         p = undefined;
254       else
255         switch (u->flags.delim)
256           {
257           case DELIM_NONE:
258             p = "NONE";
259             break;
260           case DELIM_QUOTE:
261             p = "QUOTE";
262             break;
263           case DELIM_APOSTROPHE:
264             p = "APOSTROPHE";
265             break;
266           default:
267             internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
268           }
269
270       cf_strcpy (iqp->delim, iqp->delim_len, p);
271     }
272
273   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
274     {
275       if (u == NULL || u->flags.form != FORM_FORMATTED)
276         p = undefined;
277       else
278         switch (u->flags.pad)
279           {
280           case PAD_NO:
281             p = "NO";
282             break;
283           case PAD_YES:
284             p = "YES";
285             break;
286           default:
287             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
288           }
289
290       cf_strcpy (iqp->pad, iqp->pad_len, p);
291     }
292  
293   if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
294     {
295       if (u == NULL)
296         p = undefined;
297       else
298         switch (u->flags.convert)
299           {
300             /*  l8_to_l4_offset is 0 for little-endian, 1 for big-endian.  */
301           case CONVERT_NATIVE:
302             p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
303             break;
304
305           case CONVERT_SWAP:
306             p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
307             break;
308
309           default:
310             internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
311           }
312
313       cf_strcpy (iqp->convert, iqp->convert_len, p);
314     }
315 }
316
317
318 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
319  * only used if the filename is *not* connected to a unit number. */
320
321 static void
322 inquire_via_filename (st_parameter_inquire *iqp)
323 {
324   const char *p;
325   GFC_INTEGER_4 cf = iqp->common.flags;
326
327   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
328     *iqp->exist = file_exists (iqp->file, iqp->file_len);
329
330   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
331     *iqp->opened = 0;
332
333   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
334     *iqp->number = -1;
335
336   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
337     *iqp->named = 1;
338
339   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
340     fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
341
342   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
343     cf_strcpy (iqp->access, iqp->access_len, undefined);
344
345   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
346     {
347       p = inquire_sequential (iqp->file, iqp->file_len);
348       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
349     }
350
351   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
352     {
353       p = inquire_direct (iqp->file, iqp->file_len);
354       cf_strcpy (iqp->direct, iqp->direct_len, p);
355     }
356
357   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
358     cf_strcpy (iqp->form, iqp->form_len, undefined);
359
360   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
361     {
362       p = inquire_formatted (iqp->file, iqp->file_len);
363       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
364     }
365
366   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
367     {
368       p = inquire_unformatted (iqp->file, iqp->file_len);
369       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
370     }
371
372   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
373     *iqp->recl_out = 0;
374
375   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
376     *iqp->nextrec = 0;
377
378   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
379     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
380
381   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
382     cf_strcpy (iqp->position, iqp->position_len, undefined);
383
384   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
385     cf_strcpy (iqp->access, iqp->access_len, undefined);
386
387   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
388     {
389       p = inquire_read (iqp->file, iqp->file_len);
390       cf_strcpy (iqp->read, iqp->read_len, p);
391     }
392
393   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
394     {
395       p = inquire_write (iqp->file, iqp->file_len);
396       cf_strcpy (iqp->write, iqp->write_len, p);
397     }
398
399   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
400     {
401       p = inquire_read (iqp->file, iqp->file_len);
402       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
403     }
404
405   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
406     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
407
408   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
409     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
410 }
411
412
413 /* Library entry point for the INQUIRE statement (non-IOLENGTH
414    form).  */
415
416 extern void st_inquire (st_parameter_inquire *);
417 export_proto(st_inquire);
418
419 void
420 st_inquire (st_parameter_inquire *iqp)
421 {
422   gfc_unit *u;
423
424   library_start (&iqp->common);
425
426   if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
427     {
428       u = find_unit (iqp->common.unit);
429       inquire_via_unit (iqp, u);
430     }
431   else
432     {
433       u = find_file (iqp->file, iqp->file_len);
434       if (u == NULL)
435         inquire_via_filename (iqp);
436       else
437         inquire_via_unit (iqp, u);
438     }
439   if (u != NULL)
440     unlock_unit (u);
441
442   library_end ();
443 }