]>
Commit | Line | Data |
---|---|---|
60c514ba | 1 | /* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc. |
4ee9c684 | 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 | ||
b417ea8c | 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 | ||
4ee9c684 | 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 | |
5ac2525b | 27 | the Free Software Foundation, 51 Franklin Street, Fifth Floor, |
28 | Boston, MA 02110-1301, USA. */ | |
4ee9c684 | 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 | ||
fb35179a | 38 | static const char undefined[] = "UNDEFINED"; |
4ee9c684 | 39 | |
40 | ||
41 | /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */ | |
42 | ||
43 | static void | |
60c514ba | 44 | inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) |
4ee9c684 | 45 | { |
46 | const char *p; | |
60c514ba | 47 | GFC_INTEGER_4 cf = iqp->common.flags; |
4ee9c684 | 48 | |
60c514ba | 49 | if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) |
50 | *iqp->exist = iqp->common.unit >= 0; | |
4ee9c684 | 51 | |
60c514ba | 52 | if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) |
53 | *iqp->opened = (u != NULL); | |
4ee9c684 | 54 | |
60c514ba | 55 | if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0) |
56 | *iqp->number = (u != NULL) ? u->unit_number : -1; | |
4ee9c684 | 57 | |
60c514ba | 58 | if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0) |
59 | *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH); | |
4ee9c684 | 60 | |
60c514ba | 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); | |
4ee9c684 | 64 | |
60c514ba | 65 | if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) |
4ee9c684 | 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; | |
4d8ee55b | 78 | case ACCESS_STREAM: |
79 | p = "STREAM"; | |
80 | break; | |
4ee9c684 | 81 | default: |
60c514ba | 82 | internal_error (&iqp->common, "inquire_via_unit(): Bad access"); |
4ee9c684 | 83 | } |
84 | ||
60c514ba | 85 | cf_strcpy (iqp->access, iqp->access_len, p); |
4ee9c684 | 86 | } |
87 | ||
60c514ba | 88 | if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0) |
4ee9c684 | 89 | { |
214b69f2 | 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 | } | |
4ee9c684 | 100 | |
60c514ba | 101 | cf_strcpy (iqp->sequential, iqp->sequential_len, p); |
4ee9c684 | 102 | } |
103 | ||
60c514ba | 104 | if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) |
4ee9c684 | 105 | { |
106 | p = (u == NULL) ? inquire_direct (NULL, 0) : | |
107 | inquire_direct (u->file, u->file_len); | |
108 | ||
60c514ba | 109 | cf_strcpy (iqp->direct, iqp->direct_len, p); |
4ee9c684 | 110 | } |
111 | ||
60c514ba | 112 | if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0) |
4ee9c684 | 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: | |
60c514ba | 126 | internal_error (&iqp->common, "inquire_via_unit(): Bad form"); |
4ee9c684 | 127 | } |
128 | ||
60c514ba | 129 | cf_strcpy (iqp->form, iqp->form_len, p); |
4ee9c684 | 130 | } |
131 | ||
60c514ba | 132 | if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) |
4ee9c684 | 133 | { |
134 | p = (u == NULL) ? inquire_formatted (NULL, 0) : | |
135 | inquire_formatted (u->file, u->file_len); | |
136 | ||
60c514ba | 137 | cf_strcpy (iqp->formatted, iqp->formatted_len, p); |
4ee9c684 | 138 | } |
139 | ||
60c514ba | 140 | if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) |
4ee9c684 | 141 | { |
142 | p = (u == NULL) ? inquire_unformatted (NULL, 0) : | |
143 | inquire_unformatted (u->file, u->file_len); | |
144 | ||
60c514ba | 145 | cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); |
4ee9c684 | 146 | } |
147 | ||
60c514ba | 148 | if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0) |
149 | *iqp->recl_out = (u != NULL) ? u->recl : 0; | |
4ee9c684 | 150 | |
4d8ee55b | 151 | if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0) |
152 | *iqp->strm_pos_out = (u != NULL) ? u->last_record : 0; | |
153 | ||
60c514ba | 154 | if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0) |
155 | *iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0; | |
4ee9c684 | 156 | |
60c514ba | 157 | if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0) |
4ee9c684 | 158 | { |
159 | if (u == NULL) | |
160 | p = undefined; | |
161 | else | |
162 | switch (u->flags.blank) | |
163 | { | |
164 | case BLANK_NULL: | |
60c514ba | 165 | p = "NULL"; |
4ee9c684 | 166 | break; |
167 | case BLANK_ZERO: | |
168 | p = "ZERO"; | |
169 | break; | |
170 | default: | |
60c514ba | 171 | internal_error (&iqp->common, "inquire_via_unit(): Bad blank"); |
4ee9c684 | 172 | } |
173 | ||
60c514ba | 174 | cf_strcpy (iqp->blank, iqp->blank_len, p); |
4ee9c684 | 175 | } |
176 | ||
60c514ba | 177 | if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) |
4ee9c684 | 178 | { |
179 | if (u == NULL || u->flags.access == ACCESS_DIRECT) | |
b3b0377b | 180 | p = undefined; |
4ee9c684 | 181 | else |
b3b0377b | 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 | } | |
60c514ba | 200 | cf_strcpy (iqp->position, iqp->position_len, p); |
4ee9c684 | 201 | } |
202 | ||
60c514ba | 203 | if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0) |
4ee9c684 | 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: | |
60c514ba | 220 | internal_error (&iqp->common, "inquire_via_unit(): Bad action"); |
4ee9c684 | 221 | } |
222 | ||
60c514ba | 223 | cf_strcpy (iqp->action, iqp->action_len, p); |
4ee9c684 | 224 | } |
225 | ||
60c514ba | 226 | if ((cf & IOPARM_INQUIRE_HAS_READ) != 0) |
4ee9c684 | 227 | { |
228 | p = (u == NULL) ? inquire_read (NULL, 0) : | |
229 | inquire_read (u->file, u->file_len); | |
230 | ||
60c514ba | 231 | cf_strcpy (iqp->read, iqp->read_len, p); |
4ee9c684 | 232 | } |
233 | ||
60c514ba | 234 | if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0) |
4ee9c684 | 235 | { |
236 | p = (u == NULL) ? inquire_write (NULL, 0) : | |
237 | inquire_write (u->file, u->file_len); | |
238 | ||
60c514ba | 239 | cf_strcpy (iqp->write, iqp->write_len, p); |
4ee9c684 | 240 | } |
241 | ||
60c514ba | 242 | if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0) |
4ee9c684 | 243 | { |
244 | p = (u == NULL) ? inquire_readwrite (NULL, 0) : | |
245 | inquire_readwrite (u->file, u->file_len); | |
246 | ||
60c514ba | 247 | cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); |
4ee9c684 | 248 | } |
249 | ||
60c514ba | 250 | if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0) |
4ee9c684 | 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: | |
60c514ba | 267 | internal_error (&iqp->common, "inquire_via_unit(): Bad delim"); |
4ee9c684 | 268 | } |
269 | ||
60c514ba | 270 | cf_strcpy (iqp->delim, iqp->delim_len, p); |
4ee9c684 | 271 | } |
272 | ||
60c514ba | 273 | if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) |
4ee9c684 | 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: | |
60c514ba | 287 | internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); |
4ee9c684 | 288 | } |
289 | ||
60c514ba | 290 | cf_strcpy (iqp->pad, iqp->pad_len, p); |
4ee9c684 | 291 | } |
9e94d29f | 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 | } | |
4ee9c684 | 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 | |
60c514ba | 322 | inquire_via_filename (st_parameter_inquire *iqp) |
4ee9c684 | 323 | { |
324 | const char *p; | |
60c514ba | 325 | GFC_INTEGER_4 cf = iqp->common.flags; |
4ee9c684 | 326 | |
60c514ba | 327 | if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) |
328 | *iqp->exist = file_exists (iqp->file, iqp->file_len); | |
4ee9c684 | 329 | |
60c514ba | 330 | if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) |
331 | *iqp->opened = 0; | |
4ee9c684 | 332 | |
60c514ba | 333 | if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0) |
334 | *iqp->number = -1; | |
4ee9c684 | 335 | |
60c514ba | 336 | if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0) |
337 | *iqp->named = 1; | |
4ee9c684 | 338 | |
60c514ba | 339 | if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0) |
340 | fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len); | |
4ee9c684 | 341 | |
60c514ba | 342 | if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) |
343 | cf_strcpy (iqp->access, iqp->access_len, undefined); | |
4ee9c684 | 344 | |
60c514ba | 345 | if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0) |
4ee9c684 | 346 | { |
60c514ba | 347 | p = inquire_sequential (iqp->file, iqp->file_len); |
348 | cf_strcpy (iqp->sequential, iqp->sequential_len, p); | |
4ee9c684 | 349 | } |
350 | ||
60c514ba | 351 | if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) |
4ee9c684 | 352 | { |
60c514ba | 353 | p = inquire_direct (iqp->file, iqp->file_len); |
354 | cf_strcpy (iqp->direct, iqp->direct_len, p); | |
4ee9c684 | 355 | } |
356 | ||
60c514ba | 357 | if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0) |
358 | cf_strcpy (iqp->form, iqp->form_len, undefined); | |
4ee9c684 | 359 | |
60c514ba | 360 | if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) |
4ee9c684 | 361 | { |
60c514ba | 362 | p = inquire_formatted (iqp->file, iqp->file_len); |
363 | cf_strcpy (iqp->formatted, iqp->formatted_len, p); | |
4ee9c684 | 364 | } |
365 | ||
60c514ba | 366 | if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) |
4ee9c684 | 367 | { |
60c514ba | 368 | p = inquire_unformatted (iqp->file, iqp->file_len); |
369 | cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); | |
4ee9c684 | 370 | } |
371 | ||
60c514ba | 372 | if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0) |
373 | *iqp->recl_out = 0; | |
4ee9c684 | 374 | |
60c514ba | 375 | if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0) |
376 | *iqp->nextrec = 0; | |
4ee9c684 | 377 | |
60c514ba | 378 | if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0) |
379 | cf_strcpy (iqp->blank, iqp->blank_len, undefined); | |
4ee9c684 | 380 | |
60c514ba | 381 | if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) |
382 | cf_strcpy (iqp->position, iqp->position_len, undefined); | |
4ee9c684 | 383 | |
60c514ba | 384 | if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) |
385 | cf_strcpy (iqp->access, iqp->access_len, undefined); | |
4ee9c684 | 386 | |
60c514ba | 387 | if ((cf & IOPARM_INQUIRE_HAS_READ) != 0) |
4ee9c684 | 388 | { |
60c514ba | 389 | p = inquire_read (iqp->file, iqp->file_len); |
390 | cf_strcpy (iqp->read, iqp->read_len, p); | |
4ee9c684 | 391 | } |
392 | ||
60c514ba | 393 | if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0) |
4ee9c684 | 394 | { |
60c514ba | 395 | p = inquire_write (iqp->file, iqp->file_len); |
396 | cf_strcpy (iqp->write, iqp->write_len, p); | |
4ee9c684 | 397 | } |
398 | ||
60c514ba | 399 | if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0) |
4ee9c684 | 400 | { |
60c514ba | 401 | p = inquire_read (iqp->file, iqp->file_len); |
402 | cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); | |
4ee9c684 | 403 | } |
404 | ||
60c514ba | 405 | if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0) |
406 | cf_strcpy (iqp->delim, iqp->delim_len, undefined); | |
4ee9c684 | 407 | |
60c514ba | 408 | if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) |
409 | cf_strcpy (iqp->pad, iqp->pad_len, undefined); | |
4ee9c684 | 410 | } |
411 | ||
412 | ||
6799e2f8 | 413 | /* Library entry point for the INQUIRE statement (non-IOLENGTH |
414 | form). */ | |
4ee9c684 | 415 | |
60c514ba | 416 | extern void st_inquire (st_parameter_inquire *); |
7b6cb5bd | 417 | export_proto(st_inquire); |
418 | ||
4ee9c684 | 419 | void |
60c514ba | 420 | st_inquire (st_parameter_inquire *iqp) |
4ee9c684 | 421 | { |
f02dd226 | 422 | gfc_unit *u; |
4ee9c684 | 423 | |
60c514ba | 424 | library_start (&iqp->common); |
4ee9c684 | 425 | |
60c514ba | 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 | } | |
4ee9c684 | 431 | else |
432 | { | |
60c514ba | 433 | u = find_file (iqp->file, iqp->file_len); |
4ee9c684 | 434 | if (u == NULL) |
60c514ba | 435 | inquire_via_filename (iqp); |
4ee9c684 | 436 | else |
60c514ba | 437 | inquire_via_unit (iqp, u); |
4ee9c684 | 438 | } |
60c514ba | 439 | if (u != NULL) |
440 | unlock_unit (u); | |
4ee9c684 | 441 | |
442 | library_end (); | |
443 | } |