OSDN Git Service

1f0fcac6530fa40697fad6e1d64f9a8daf670e47
[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, 59 Temple Place - Suite 330,
28 Boston, MA 02111-1307, 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       /* disallow an open direct access file to be accessed
91          sequentially */
92       if (u->flags.access==ACCESS_DIRECT)
93         p = "NO";
94       else   
95         p = (u == NULL) ? inquire_sequential (NULL, 0) :
96         inquire_sequential (u->file, u->file_len);
97
98       cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
99     }
100
101   if (ioparm.direct != NULL)
102     {
103       p = (u == NULL) ? inquire_direct (NULL, 0) :
104         inquire_direct (u->file, u->file_len);
105
106       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
107     }
108
109   if (ioparm.form != NULL)
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 ("inquire_via_unit(): Bad form");
124           }
125
126       cf_strcpy (ioparm.form, ioparm.form_len, p);
127     }
128
129   if (ioparm.formatted != NULL)
130     {
131       p = (u == NULL) ? inquire_formatted (NULL, 0) :
132         inquire_formatted (u->file, u->file_len);
133
134       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
135     }
136
137   if (ioparm.unformatted != NULL)
138     {
139       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
140         inquire_unformatted (u->file, u->file_len);
141
142       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
143     }
144
145   if (ioparm.recl_out != NULL)
146     *ioparm.recl_out = (u != NULL) ? u->recl : 0;
147
148   if (ioparm.nextrec != NULL)
149     *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
150
151   if (ioparm.blank != NULL)
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 ("inquire_via_unit(): Bad blank");
166           }
167
168       cf_strcpy (ioparm.blank, ioparm.blank_len, p);
169     }
170
171   if (ioparm.position != NULL)
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 (ioparm.position, ioparm.position_len, p);
195     }
196
197   if (ioparm.action != NULL)
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 ("inquire_via_unit(): Bad action");
215           }
216
217       cf_strcpy (ioparm.action, ioparm.action_len, p);
218     }
219
220   if (ioparm.read != NULL)
221     {
222       p = (u == NULL) ? inquire_read (NULL, 0) :
223         inquire_read (u->file, u->file_len);
224
225       cf_strcpy (ioparm.read, ioparm.read_len, p);
226     }
227
228   if (ioparm.write != NULL)
229     {
230       p = (u == NULL) ? inquire_write (NULL, 0) :
231         inquire_write (u->file, u->file_len);
232
233       cf_strcpy (ioparm.write, ioparm.write_len, p);
234     }
235
236   if (ioparm.readwrite != NULL)
237     {
238       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
239         inquire_readwrite (u->file, u->file_len);
240
241       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
242     }
243
244   if (ioparm.delim != NULL)
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 ("inquire_via_unit(): Bad delim");
262           }
263
264       cf_strcpy (ioparm.delim, ioparm.delim_len, p);
265     }
266
267   if (ioparm.pad != NULL)
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 ("inquire_via_unit(): Bad pad");
282           }
283
284       cf_strcpy (ioparm.pad, ioparm.pad_len, p);
285     }
286 }
287
288
289 /* inquire_via_filename()-- Inquiry via filename.  This subroutine is
290  * only used if the filename is *not* connected to a unit number. */
291
292 static void
293 inquire_via_filename (void)
294 {
295   const char *p;
296
297   if (ioparm.exist != NULL)
298     *ioparm.exist = file_exists ();
299
300   if (ioparm.opened != NULL)
301     *ioparm.opened = 0;
302
303   if (ioparm.number != NULL)
304     *ioparm.number = -1;
305
306   if (ioparm.named != NULL)
307     *ioparm.named = 1;
308
309   if (ioparm.name != NULL)
310     fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
311
312   if (ioparm.access != NULL)
313     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
314
315   if (ioparm.sequential != NULL)
316     {
317       p = inquire_sequential (ioparm.file, ioparm.file_len);
318       cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
319     }
320
321   if (ioparm.direct != NULL)
322     {
323       p = inquire_direct (ioparm.file, ioparm.file_len);
324       cf_strcpy (ioparm.direct, ioparm.direct_len, p);
325     }
326
327   if (ioparm.form != NULL)
328     cf_strcpy (ioparm.form, ioparm.form_len, undefined);
329
330   if (ioparm.formatted != NULL)
331     {
332       p = inquire_formatted (ioparm.file, ioparm.file_len);
333       cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
334     }
335
336   if (ioparm.unformatted != NULL)
337     {
338       p = inquire_unformatted (ioparm.file, ioparm.file_len);
339       cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
340     }
341
342   if (ioparm.recl_out != NULL)
343     *ioparm.recl_out = 0;
344
345   if (ioparm.nextrec != NULL)
346     *ioparm.nextrec = 0;
347
348   if (ioparm.blank != NULL)
349     cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
350
351   if (ioparm.position != NULL)
352     cf_strcpy (ioparm.position, ioparm.position_len, undefined);
353
354   if (ioparm.access != NULL)
355     cf_strcpy (ioparm.access, ioparm.access_len, undefined);
356
357   if (ioparm.read != NULL)
358     {
359       p = inquire_read (ioparm.file, ioparm.file_len);
360       cf_strcpy (ioparm.read, ioparm.read_len, p);
361     }
362
363   if (ioparm.write != NULL)
364     {
365       p = inquire_write (ioparm.file, ioparm.file_len);
366       cf_strcpy (ioparm.write, ioparm.write_len, p);
367     }
368
369   if (ioparm.readwrite != NULL)
370     {
371       p = inquire_read (ioparm.file, ioparm.file_len);
372       cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
373     }
374
375   if (ioparm.delim != NULL)
376     cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
377
378   if (ioparm.pad != NULL)
379     cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
380
381 }
382
383
384 /* Library entry point for the INQUIRE statement (non-IOLENGTH
385    form).  */
386
387 extern void st_inquire (void);
388 export_proto(st_inquire);
389
390 void
391 st_inquire (void)
392 {
393   gfc_unit *u;
394
395   library_start ();
396
397   if (ioparm.file == NULL)
398     inquire_via_unit (find_unit (ioparm.unit));
399   else
400     {
401       u = find_file ();
402       if (u == NULL)
403         inquire_via_filename ();
404       else
405         inquire_via_unit (u);
406     }
407
408   library_end ();
409 }