]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/io/inquire.c
1 /* Copyright (C) 2002-2003 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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)
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
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.
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. */
31 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
34 #include "libgfortran.h"
38 static char undefined
[] = "UNDEFINED";
41 /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
44 inquire_via_unit (gfc_unit
* u
)
48 if (ioparm
.exist
!= NULL
)
49 *ioparm
.exist
= (u
!= NULL
);
51 if (ioparm
.opened
!= NULL
)
52 *ioparm
.opened
= (u
!= NULL
);
54 if (ioparm
.number
!= NULL
)
55 *ioparm
.number
= (u
!= NULL
) ? u
->unit_number
: -1;
57 if (ioparm
.named
!= NULL
)
58 *ioparm
.named
= (u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
);
60 if (ioparm
.name
!= NULL
&& u
!= NULL
&& u
->flags
.status
!= STATUS_SCRATCH
)
61 fstrcpy (ioparm
.name
, ioparm
.name_len
, u
->file
, u
->file_len
);
63 if (ioparm
.access
!= NULL
)
68 switch (u
->flags
.access
)
70 case ACCESS_SEQUENTIAL
:
77 internal_error ("inquire_via_unit(): Bad access");
80 cf_strcpy (ioparm
.access
, ioparm
.access_len
, p
);
83 if (ioparm
.sequential
!= NULL
)
85 /* disallow an open direct access file to be accessed
87 if (u
->flags
.access
==ACCESS_DIRECT
)
90 p
= (u
== NULL
) ? inquire_sequential (NULL
, 0) :
91 inquire_sequential (u
->file
, u
->file_len
);
93 cf_strcpy (ioparm
.sequential
, ioparm
.sequential_len
, p
);
96 if (ioparm
.direct
!= NULL
)
98 p
= (u
== NULL
) ? inquire_direct (NULL
, 0) :
99 inquire_direct (u
->file
, u
->file_len
);
101 cf_strcpy (ioparm
.direct
, ioparm
.direct_len
, p
);
104 if (ioparm
.form
!= NULL
)
109 switch (u
->flags
.form
)
114 case FORM_UNFORMATTED
:
118 internal_error ("inquire_via_unit(): Bad form");
121 cf_strcpy (ioparm
.form
, ioparm
.form_len
, p
);
124 if (ioparm
.formatted
!= NULL
)
126 p
= (u
== NULL
) ? inquire_formatted (NULL
, 0) :
127 inquire_formatted (u
->file
, u
->file_len
);
129 cf_strcpy (ioparm
.formatted
, ioparm
.formatted_len
, p
);
132 if (ioparm
.unformatted
!= NULL
)
134 p
= (u
== NULL
) ? inquire_unformatted (NULL
, 0) :
135 inquire_unformatted (u
->file
, u
->file_len
);
137 cf_strcpy (ioparm
.unformatted
, ioparm
.unformatted_len
, p
);
140 if (ioparm
.recl_out
!= NULL
)
141 *ioparm
.recl_out
= (u
!= NULL
) ? u
->recl
: 0;
143 if (ioparm
.nextrec
!= NULL
)
144 *ioparm
.nextrec
= (u
!= NULL
) ? u
->last_record
+ 1 : 0;
146 if (ioparm
.blank
!= NULL
)
151 switch (u
->flags
.blank
)
160 internal_error ("inquire_via_unit(): Bad blank");
163 cf_strcpy (ioparm
.blank
, ioparm
.blank_len
, p
);
166 if (ioparm
.position
!= NULL
)
168 if (u
== NULL
|| u
->flags
.access
== ACCESS_DIRECT
)
172 p
= NULL
; /* TODO: Try to decode what the standard says... */
175 cf_strcpy (ioparm
.blank
, ioparm
.blank_len
, p
);
178 if (ioparm
.action
!= NULL
)
183 switch (u
->flags
.action
)
191 case ACTION_READWRITE
:
195 internal_error ("inquire_via_unit(): Bad action");
198 cf_strcpy (ioparm
.action
, ioparm
.action_len
, p
);
201 if (ioparm
.read
!= NULL
)
203 p
= (u
== NULL
) ? inquire_read (NULL
, 0) :
204 inquire_read (u
->file
, u
->file_len
);
206 cf_strcpy (ioparm
.read
, ioparm
.read_len
, p
);
209 if (ioparm
.write
!= NULL
)
211 p
= (u
== NULL
) ? inquire_write (NULL
, 0) :
212 inquire_write (u
->file
, u
->file_len
);
214 cf_strcpy (ioparm
.write
, ioparm
.write_len
, p
);
217 if (ioparm
.readwrite
!= NULL
)
219 p
= (u
== NULL
) ? inquire_readwrite (NULL
, 0) :
220 inquire_readwrite (u
->file
, u
->file_len
);
222 cf_strcpy (ioparm
.readwrite
, ioparm
.readwrite_len
, p
);
225 if (ioparm
.delim
!= NULL
)
227 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
230 switch (u
->flags
.delim
)
238 case DELIM_APOSTROPHE
:
242 internal_error ("inquire_via_unit(): Bad delim");
245 cf_strcpy (ioparm
.access
, ioparm
.access_len
, p
);
248 if (ioparm
.pad
!= NULL
)
250 if (u
== NULL
|| u
->flags
.form
!= FORM_FORMATTED
)
253 switch (u
->flags
.pad
)
262 internal_error ("inquire_via_unit(): Bad pad");
265 cf_strcpy (ioparm
.pad
, ioparm
.pad_len
, p
);
270 /* inquire_via_filename()-- Inquiry via filename. This subroutine is
271 * only used if the filename is *not* connected to a unit number. */
274 inquire_via_filename (void)
278 if (ioparm
.exist
!= NULL
)
279 *ioparm
.exist
= file_exists ();
281 if (ioparm
.opened
!= NULL
)
284 if (ioparm
.number
!= NULL
)
287 if (ioparm
.named
!= NULL
)
290 if (ioparm
.name
!= NULL
)
291 fstrcpy (ioparm
.name
, ioparm
.name_len
, ioparm
.file
, ioparm
.file_len
);
293 if (ioparm
.access
!= NULL
)
294 cf_strcpy (ioparm
.access
, ioparm
.access_len
, undefined
);
296 if (ioparm
.sequential
!= NULL
)
298 p
= inquire_sequential (ioparm
.file
, ioparm
.file_len
);
299 cf_strcpy (ioparm
.sequential
, ioparm
.sequential_len
, p
);
302 if (ioparm
.direct
!= NULL
)
304 p
= inquire_direct (ioparm
.file
, ioparm
.file_len
);
305 cf_strcpy (ioparm
.direct
, ioparm
.direct_len
, p
);
308 if (ioparm
.form
!= NULL
)
309 cf_strcpy (ioparm
.form
, ioparm
.form_len
, undefined
);
311 if (ioparm
.formatted
!= NULL
)
313 p
= inquire_formatted (ioparm
.file
, ioparm
.file_len
);
314 cf_strcpy (ioparm
.formatted
, ioparm
.formatted_len
, p
);
317 if (ioparm
.unformatted
!= NULL
)
319 p
= inquire_unformatted (ioparm
.file
, ioparm
.file_len
);
320 cf_strcpy (ioparm
.unformatted
, ioparm
.unformatted_len
, p
);
323 if (ioparm
.recl_out
!= NULL
)
324 *ioparm
.recl_out
= 0;
326 if (ioparm
.nextrec
!= NULL
)
329 if (ioparm
.blank
!= NULL
)
330 cf_strcpy (ioparm
.blank
, ioparm
.blank_len
, undefined
);
332 if (ioparm
.position
!= NULL
)
333 cf_strcpy (ioparm
.position
, ioparm
.position_len
, undefined
);
335 if (ioparm
.access
!= NULL
)
336 cf_strcpy (ioparm
.access
, ioparm
.access_len
, undefined
);
338 if (ioparm
.read
!= NULL
)
340 p
= inquire_read (ioparm
.file
, ioparm
.file_len
);
341 cf_strcpy (ioparm
.read
, ioparm
.read_len
, p
);
344 if (ioparm
.write
!= NULL
)
346 p
= inquire_write (ioparm
.file
, ioparm
.file_len
);
347 cf_strcpy (ioparm
.write
, ioparm
.write_len
, p
);
350 if (ioparm
.readwrite
!= NULL
)
352 p
= inquire_read (ioparm
.file
, ioparm
.file_len
);
353 cf_strcpy (ioparm
.readwrite
, ioparm
.readwrite_len
, p
);
356 if (ioparm
.delim
!= NULL
)
357 cf_strcpy (ioparm
.delim
, ioparm
.delim_len
, undefined
);
359 if (ioparm
.pad
!= NULL
)
360 cf_strcpy (ioparm
.pad
, ioparm
.pad_len
, undefined
);
365 /* Library entry point for the INQUIRE statement (non-IOLENGTH
368 extern void st_inquire (void);
369 export_proto(st_inquire
);
378 if (ioparm
.file
== NULL
)
379 inquire_via_unit (find_unit (ioparm
.unit
));
384 inquire_via_filename ();
386 inquire_via_unit (u
);