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           default:
79             internal_error (&iqp->common, "inquire_via_unit(): Bad access");
80           }
81
82       cf_strcpy (iqp->access, iqp->access_len, p);
83     }
84
85   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
86     {
87       if (u == NULL)
88         p = inquire_sequential (NULL, 0);
89       else
90         {
91           /* disallow an open direct access file to be accessed sequentially */
92           if (u->flags.access == ACCESS_DIRECT)
93             p = "NO";
94           else   
95             p = inquire_sequential (u->file, u->file_len);
96         }
97
98       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
99     }
100
101   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
102     {
103       p = (u == NULL) ? inquire_direct (NULL, 0) :
104         inquire_direct (u->file, u->file_len);
105
106       cf_strcpy (iqp->direct, iqp->direct_len, p);
107     }
108
109   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
110     {
111       if (u == NULL)
112         p = undefined;
113       else
114         switch (u->flags.form)
115           {
116           case FORM_FORMATTED:
117             p = "FORMATTED";
118             break;
119           case FORM_UNFORMATTED:
120             p = "UNFORMATTED";
121             break;
122           default:
123             internal_error (&iqp->common, "inquire_via_unit(): Bad form");
124           }
125
126       cf_strcpy (iqp->form, iqp->form_len, p);
127     }
128
129   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
130     {
131       p = (u == NULL) ? inquire_formatted (NULL, 0) :
132         inquire_formatted (u->file, u->file_len);
133
134       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
135     }
136
137   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
138     {
139       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
140         inquire_unformatted (u->file, u->file_len);
141
142       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
143     }
144
145   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
146     *iqp->recl_out = (u != NULL) ? u->recl : 0;
147
148   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
149     *iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0;
150
151   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
152     {
153       if (u == NULL)
154         p = undefined;
155       else
156         switch (u->flags.blank)
157           {
158           case BLANK_NULL:
159             p = "NULL";
160             break;
161           case BLANK_ZERO:
162             p = "ZERO";
163             break;
164           default:
165             internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
166           }
167
168       cf_strcpy (iqp->blank, iqp->blank_len, p);
169     }
170
171   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
172     {
173       if (u == NULL || u->flags.access == ACCESS_DIRECT)
174         p = undefined;
175       else
176         switch (u->flags.position)
177           {
178              case POSITION_REWIND:
179                p = "REWIND";
180                break;
181              case POSITION_APPEND:
182                p = "APPEND";
183                break;
184              case POSITION_ASIS:
185                p = "ASIS";
186                break;
187              default:
188                /* if not direct access, it must be
189                   either REWIND, APPEND, or ASIS.
190                   ASIS seems to be the best default */
191                p = "ASIS";
192                break;
193           }
194       cf_strcpy (iqp->position, iqp->position_len, p);
195     }
196
197   if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
198     {
199       if (u == NULL)
200         p = undefined;
201       else
202         switch (u->flags.action)
203           {
204           case ACTION_READ:
205             p = "READ";
206             break;
207           case ACTION_WRITE:
208             p = "WRITE";
209             break;
210           case ACTION_READWRITE:
211             p = "READWRITE";
212             break;
213           default:
214             internal_error (&iqp->common, "inquire_via_unit(): Bad action");
215           }
216
217       cf_strcpy (iqp->action, iqp->action_len, p);
218     }
219
220   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
221     {
222       p = (u == NULL) ? inquire_read (NULL, 0) :
223         inquire_read (u->file, u->file_len);
224
225       cf_strcpy (iqp->read, iqp->read_len, p);
226     }
227
228   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
229     {
230       p = (u == NULL) ? inquire_write (NULL, 0) :
231         inquire_write (u->file, u->file_len);
232
233       cf_strcpy (iqp->write, iqp->write_len, p);
234     }
235
236   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
237     {
238       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
239         inquire_readwrite (u->file, u->file_len);
240
241       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
242     }
243
244   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
245     {
246       if (u == NULL || u->flags.form != FORM_FORMATTED)
247         p = undefined;
248       else
249         switch (u->flags.delim)
250           {
251           case DELIM_NONE:
252             p = "NONE";
253             break;
254           case DELIM_QUOTE:
255             p = "QUOTE";
256             break;
257           case DELIM_APOSTROPHE:
258             p = "APOSTROPHE";
259             break;
260           default:
261             internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
262           }
263
264       cf_strcpy (iqp->delim, iqp->delim_len, p);
265     }
266
267   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
268     {
269       if (u == NULL || u->flags.form != FORM_FORMATTED)
270         p = undefined;
271       else
272         switch (u->flags.pad)
273           {
274           case PAD_NO:
275             p = "NO";
276             break;
277           case PAD_YES:
278             p = "YES";
279             break;
280           default:
281             internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
282           }
283
284       cf_strcpy (iqp->pad, iqp->pad_len, p);
285     }
286  
287   if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
288     {
289       if (u == NULL)
290         p = undefined;
291       else
292         switch (u->flags.convert)
293           {
294             /*  l8_to_l4_offset is 0 for little-endian, 1 for big-endian.  */
295           case CONVERT_NATIVE:
296             p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
297             break;
298
299           case CONVERT_SWAP:
300             p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
301             break;
302
303           default:
304             internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
305           }
306
307       cf_strcpy (iqp->convert, iqp->convert_len, p);
308     }
309 }
310
311
312 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
313  * only used if the filename is *not* connected to a unit number. */
314
315 static void
316 inquire_via_filename (st_parameter_inquire *iqp)
317 {
318   const char *p;
319   GFC_INTEGER_4 cf = iqp->common.flags;
320
321   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
322     *iqp->exist = file_exists (iqp->file, iqp->file_len);
323
324   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
325     *iqp->opened = 0;
326
327   if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
328     *iqp->number = -1;
329
330   if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
331     *iqp->named = 1;
332
333   if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
334     fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
335
336   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
337     cf_strcpy (iqp->access, iqp->access_len, undefined);
338
339   if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
340     {
341       p = inquire_sequential (iqp->file, iqp->file_len);
342       cf_strcpy (iqp->sequential, iqp->sequential_len, p);
343     }
344
345   if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
346     {
347       p = inquire_direct (iqp->file, iqp->file_len);
348       cf_strcpy (iqp->direct, iqp->direct_len, p);
349     }
350
351   if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
352     cf_strcpy (iqp->form, iqp->form_len, undefined);
353
354   if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
355     {
356       p = inquire_formatted (iqp->file, iqp->file_len);
357       cf_strcpy (iqp->formatted, iqp->formatted_len, p);
358     }
359
360   if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
361     {
362       p = inquire_unformatted (iqp->file, iqp->file_len);
363       cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
364     }
365
366   if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
367     *iqp->recl_out = 0;
368
369   if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
370     *iqp->nextrec = 0;
371
372   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
373     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
374
375   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
376     cf_strcpy (iqp->position, iqp->position_len, undefined);
377
378   if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
379     cf_strcpy (iqp->access, iqp->access_len, undefined);
380
381   if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
382     {
383       p = inquire_read (iqp->file, iqp->file_len);
384       cf_strcpy (iqp->read, iqp->read_len, p);
385     }
386
387   if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
388     {
389       p = inquire_write (iqp->file, iqp->file_len);
390       cf_strcpy (iqp->write, iqp->write_len, p);
391     }
392
393   if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
394     {
395       p = inquire_read (iqp->file, iqp->file_len);
396       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
397     }
398
399   if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
400     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
401
402   if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
403     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
404 }
405
406
407 /* Library entry point for the INQUIRE statement (non-IOLENGTH
408    form).  */
409
410 extern void st_inquire (st_parameter_inquire *);
411 export_proto(st_inquire);
412
413 void
414 st_inquire (st_parameter_inquire *iqp)
415 {
416   gfc_unit *u;
417
418   library_start (&iqp->common);
419
420   if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
421     {
422       u = find_unit (iqp->common.unit);
423       inquire_via_unit (iqp, u);
424     }
425   else
426     {
427       u = find_file (iqp->file, iqp->file_len);
428       if (u == NULL)
429         inquire_via_filename (iqp);
430       else
431         inquire_via_unit (iqp, u);
432     }
433   if (u != NULL)
434     unlock_unit (u);
435
436   library_end ();
437 }