OSDN Git Service

31f1ad18b02fb6602e5ac5d8412c45fb4d3f5bdd
[pf3gnuchains/gcc-fork.git] / libgfortran / io / inquire.c
1 /* Copyright (C) 2002-2003 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 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 (gfc_unit * u)
45 {
46   const char *p;
47
48   if (ioparm.exist != NULL)
49   {
50     if (ioparm.unit >= 0)
51       *ioparm.exist = 1;
52     else
53       *ioparm.exist = 0;
54   }
55
56   if (ioparm.opened != NULL)
57     *ioparm.opened = (u != NULL);
58
59   if (ioparm.number != NULL)
60     *ioparm.number = (u != NULL) ? u->unit_number : -1;
61
62   if (ioparm.named != NULL)
63     *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
64
65   if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
66     fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
67
68   if (ioparm.access != NULL)
69     {
70       if (u == NULL)
71         p = undefined;
72       else
73         switch (u->flags.access)
74           {
75           case ACCESS_SEQUENTIAL:
76             p = "SEQUENTIAL";
77             break;
78           case ACCESS_DIRECT:
79             p = "DIRECT";
80             break;
81           default:
82             internal_error ("inquire_via_unit(): Bad access");
83           }
84
85       cf_strcpy (ioparm.access, ioparm.access_len, p);
86     }
87
88   if (ioparm.sequential != NULL)
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 (ioparm.sequential, ioparm.sequential_len, p);
102     }
103
104   if (ioparm.direct != NULL)
105     {
106       p = (u == NULL) ? inquire_direct (NULL, 0) :
107         inquire_direct (u->file, u->file_len);
108
109       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
110     }
111
112   if (ioparm.form != NULL)
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 ("inquire_via_unit(): Bad form");
127           }
128
129       cf_strcpy (ioparm.form, ioparm.form_len, p);
130     }
131
132   if (ioparm.formatted != NULL)
133     {
134       p = (u == NULL) ? inquire_formatted (NULL, 0) :
135         inquire_formatted (u->file, u->file_len);
136
137       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
138     }
139
140   if (ioparm.unformatted != NULL)
141     {
142       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
143         inquire_unformatted (u->file, u->file_len);
144
145       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
146     }
147
148   if (ioparm.recl_out != NULL)
149     *ioparm.recl_out = (u != NULL) ? u->recl : 0;
150
151   if (ioparm.nextrec != NULL)
152     *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
153
154   if (ioparm.blank != NULL)
155     {
156       if (u == NULL)
157         p = undefined;
158       else
159         switch (u->flags.blank)
160           {
161           case BLANK_NULL:
162           p = "NULL";
163             break;
164           case BLANK_ZERO:
165             p = "ZERO";
166             break;
167           default:
168             internal_error ("inquire_via_unit(): Bad blank");
169           }
170
171       cf_strcpy (ioparm.blank, ioparm.blank_len, p);
172     }
173
174   if (ioparm.position != NULL)
175     {
176       if (u == NULL || u->flags.access == ACCESS_DIRECT)
177         p = undefined;
178       else
179         switch (u->flags.position)
180           {
181              case POSITION_REWIND:
182                p = "REWIND";
183                break;
184              case POSITION_APPEND:
185                p = "APPEND";
186                break;
187              case POSITION_ASIS:
188                p = "ASIS";
189                break;
190              default:
191                /* if not direct access, it must be
192                   either REWIND, APPEND, or ASIS.
193                   ASIS seems to be the best default */
194                p = "ASIS";
195                break;
196           }
197       cf_strcpy (ioparm.position, ioparm.position_len, p);
198     }
199
200   if (ioparm.action != NULL)
201     {
202       if (u == NULL)
203         p = undefined;
204       else
205         switch (u->flags.action)
206           {
207           case ACTION_READ:
208             p = "READ";
209             break;
210           case ACTION_WRITE:
211             p = "WRITE";
212             break;
213           case ACTION_READWRITE:
214             p = "READWRITE";
215             break;
216           default:
217             internal_error ("inquire_via_unit(): Bad action");
218           }
219
220       cf_strcpy (ioparm.action, ioparm.action_len, p);
221     }
222
223   if (ioparm.read != NULL)
224     {
225       p = (u == NULL) ? inquire_read (NULL, 0) :
226         inquire_read (u->file, u->file_len);
227
228       cf_strcpy (ioparm.read, ioparm.read_len, p);
229     }
230
231   if (ioparm.write != NULL)
232     {
233       p = (u == NULL) ? inquire_write (NULL, 0) :
234         inquire_write (u->file, u->file_len);
235
236       cf_strcpy (ioparm.write, ioparm.write_len, p);
237     }
238
239   if (ioparm.readwrite != NULL)
240     {
241       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
242         inquire_readwrite (u->file, u->file_len);
243
244       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
245     }
246
247   if (ioparm.delim != NULL)
248     {
249       if (u == NULL || u->flags.form != FORM_FORMATTED)
250         p = undefined;
251       else
252         switch (u->flags.delim)
253           {
254           case DELIM_NONE:
255             p = "NONE";
256             break;
257           case DELIM_QUOTE:
258             p = "QUOTE";
259             break;
260           case DELIM_APOSTROPHE:
261             p = "APOSTROPHE";
262             break;
263           default:
264             internal_error ("inquire_via_unit(): Bad delim");
265           }
266
267       cf_strcpy (ioparm.delim, ioparm.delim_len, p);
268     }
269
270   if (ioparm.pad != NULL)
271     {
272       if (u == NULL || u->flags.form != FORM_FORMATTED)
273         p = undefined;
274       else
275         switch (u->flags.pad)
276           {
277           case PAD_NO:
278             p = "NO";
279             break;
280           case PAD_YES:
281             p = "YES";
282             break;
283           default:
284             internal_error ("inquire_via_unit(): Bad pad");
285           }
286
287       cf_strcpy (ioparm.pad, ioparm.pad_len, p);
288     }
289 }
290
291
292 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
293  * only used if the filename is *not* connected to a unit number. */
294
295 static void
296 inquire_via_filename (void)
297 {
298   const char *p;
299
300   if (ioparm.exist != NULL)
301     *ioparm.exist = file_exists ();
302
303   if (ioparm.opened != NULL)
304     *ioparm.opened = 0;
305
306   if (ioparm.number != NULL)
307     *ioparm.number = -1;
308
309   if (ioparm.named != NULL)
310     *ioparm.named = 1;
311
312   if (ioparm.name != NULL)
313     fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
314
315   if (ioparm.access != NULL)
316     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
317
318   if (ioparm.sequential != NULL)
319     {
320       p = inquire_sequential (ioparm.file, ioparm.file_len);
321       cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
322     }
323
324   if (ioparm.direct != NULL)
325     {
326       p = inquire_direct (ioparm.file, ioparm.file_len);
327       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
328     }
329
330   if (ioparm.form != NULL)
331     cf_strcpy (ioparm.form, ioparm.form_len, undefined);
332
333   if (ioparm.formatted != NULL)
334     {
335       p = inquire_formatted (ioparm.file, ioparm.file_len);
336       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
337     }
338
339   if (ioparm.unformatted != NULL)
340     {
341       p = inquire_unformatted (ioparm.file, ioparm.file_len);
342       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
343     }
344
345   if (ioparm.recl_out != NULL)
346     *ioparm.recl_out = 0;
347
348   if (ioparm.nextrec != NULL)
349     *ioparm.nextrec = 0;
350
351   if (ioparm.blank != NULL)
352     cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
353
354   if (ioparm.position != NULL)
355     cf_strcpy (ioparm.position, ioparm.position_len, undefined);
356
357   if (ioparm.access != NULL)
358     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
359
360   if (ioparm.read != NULL)
361     {
362       p = inquire_read (ioparm.file, ioparm.file_len);
363       cf_strcpy (ioparm.read, ioparm.read_len, p);
364     }
365
366   if (ioparm.write != NULL)
367     {
368       p = inquire_write (ioparm.file, ioparm.file_len);
369       cf_strcpy (ioparm.write, ioparm.write_len, p);
370     }
371
372   if (ioparm.readwrite != NULL)
373     {
374       p = inquire_read (ioparm.file, ioparm.file_len);
375       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
376     }
377
378   if (ioparm.delim != NULL)
379     cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
380
381   if (ioparm.pad != NULL)
382     cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
383
384 }
385
386
387 /* Library entry point for the INQUIRE statement (non-IOLENGTH
388    form).  */
389
390 extern void st_inquire (void);
391 export_proto(st_inquire);
392
393 void
394 st_inquire (void)
395 {
396   gfc_unit *u;
397
398   library_start ();
399
400   if (ioparm.file == NULL)
401     inquire_via_unit (find_unit (ioparm.unit));
402   else
403     {
404       u = find_file ();
405       if (u == NULL)
406         inquire_via_filename ();
407       else
408         inquire_via_unit (u);
409     }
410
411   library_end ();
412 }