]>
Commit | Line | Data |
---|---|---|
8e8f6434 | 1 | /* Copyright (C) 2002-2018 Free Software Foundation, Inc. |
4ee9c684 | 2 | Contributed by Andy Vaught |
3 | ||
57f34837 | 4 | This file is part of the GNU Fortran runtime library (libgfortran). |
4ee9c684 | 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 | |
6bc9506f | 8 | the Free Software Foundation; either version 3, or (at your option) |
4ee9c684 | 9 | any later version. |
10 | ||
11 | Libgfortran is distributed in the hope that it will be useful, | |
12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | GNU General Public License for more details. | |
15 | ||
6bc9506f | 16 | Under Section 7 of GPL version 3, you are granted additional |
17 | permissions described in the GCC Runtime Library Exception, version | |
18 | 3.1, as published by the Free Software Foundation. | |
19 | ||
20 | You should have received a copy of the GNU General Public License and | |
21 | a copy of the GCC Runtime Library Exception along with this program; | |
22 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
23 | <http://www.gnu.org/licenses/>. */ | |
4ee9c684 | 24 | |
25 | ||
26 | /* Implement the non-IOLENGTH variant of the INQUIRY statement */ | |
27 | ||
4ee9c684 | 28 | #include "io.h" |
629c30bb | 29 | #include "async.h" |
f65f6629 | 30 | #include "unix.h" |
060da415 | 31 | #include <string.h> |
4ee9c684 | 32 | |
33 | ||
ca4dd83f | 34 | static const char yes[] = "YES", no[] = "NO", undefined[] = "UNDEFINED"; |
4ee9c684 | 35 | |
36 | ||
37 | /* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */ | |
38 | ||
39 | static void | |
25a5ce27 | 40 | inquire_via_unit (st_parameter_inquire *iqp, gfc_unit *u) |
4ee9c684 | 41 | { |
42 | const char *p; | |
60c514ba | 43 | GFC_INTEGER_4 cf = iqp->common.flags; |
4ee9c684 | 44 | |
759939bd | 45 | if (iqp->common.unit == GFC_INTERNAL_UNIT || |
46 | iqp->common.unit == GFC_INTERNAL_UNIT4 || | |
ea55eab9 | 47 | (u != NULL && u->internal_unit_kind != 0)) |
64c7e3f7 | 48 | generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL); |
49 | ||
60c514ba | 50 | if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) |
7d9dac31 | 51 | *iqp->exist = (u != NULL && |
52 | iqp->common.unit != GFC_INTERNAL_UNIT && | |
53 | iqp->common.unit != GFC_INTERNAL_UNIT4) | |
54 | || (iqp->common.unit >= 0); | |
4ee9c684 | 55 | |
60c514ba | 56 | if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) |
57 | *iqp->opened = (u != NULL); | |
4ee9c684 | 58 | |
60c514ba | 59 | if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0) |
60 | *iqp->number = (u != NULL) ? u->unit_number : -1; | |
4ee9c684 | 61 | |
60c514ba | 62 | if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0) |
63 | *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH); | |
4ee9c684 | 64 | |
60c514ba | 65 | if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0 |
66 | && u != NULL && u->flags.status != STATUS_SCRATCH) | |
4cdcb18d | 67 | { |
57f34837 | 68 | #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME) |
4cdcb18d | 69 | if (u->unit_number == options.stdin_unit |
70 | || u->unit_number == options.stdout_unit | |
71 | || u->unit_number == options.stderr_unit) | |
72 | { | |
57f34837 | 73 | int err = stream_ttyname (u->s, iqp->name, iqp->name_len); |
74 | if (err == 0) | |
4cdcb18d | 75 | { |
57f34837 | 76 | gfc_charlen_type tmplen = strlen (iqp->name); |
77 | if (iqp->name_len > tmplen) | |
78 | memset (&iqp->name[tmplen], ' ', iqp->name_len - tmplen); | |
4cdcb18d | 79 | } |
80 | else /* If ttyname does not work, go with the default. */ | |
8d832ee4 | 81 | cf_strcpy (iqp->name, iqp->name_len, u->filename); |
4cdcb18d | 82 | } |
83 | else | |
8d832ee4 | 84 | cf_strcpy (iqp->name, iqp->name_len, u->filename); |
72d2506e | 85 | #elif defined __MINGW32__ |
86 | if (u->unit_number == options.stdin_unit) | |
87 | fstrcpy (iqp->name, iqp->name_len, "CONIN$", sizeof("CONIN$")); | |
88 | else if (u->unit_number == options.stdout_unit) | |
89 | fstrcpy (iqp->name, iqp->name_len, "CONOUT$", sizeof("CONOUT$")); | |
90 | else if (u->unit_number == options.stderr_unit) | |
91 | fstrcpy (iqp->name, iqp->name_len, "CONERR$", sizeof("CONERR$")); | |
92 | else | |
99ffd2a7 | 93 | cf_strcpy (iqp->name, iqp->name_len, u->filename); |
72d2506e | 94 | #else |
91fd9679 | 95 | cf_strcpy (iqp->name, iqp->name_len, u->filename); |
72d2506e | 96 | #endif |
4cdcb18d | 97 | } |
4ee9c684 | 98 | |
60c514ba | 99 | if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) |
4ee9c684 | 100 | { |
101 | if (u == NULL) | |
102 | p = undefined; | |
103 | else | |
104 | switch (u->flags.access) | |
105 | { | |
106 | case ACCESS_SEQUENTIAL: | |
107 | p = "SEQUENTIAL"; | |
108 | break; | |
109 | case ACCESS_DIRECT: | |
110 | p = "DIRECT"; | |
111 | break; | |
4d8ee55b | 112 | case ACCESS_STREAM: |
113 | p = "STREAM"; | |
114 | break; | |
4ee9c684 | 115 | default: |
60c514ba | 116 | internal_error (&iqp->common, "inquire_via_unit(): Bad access"); |
4ee9c684 | 117 | } |
118 | ||
60c514ba | 119 | cf_strcpy (iqp->access, iqp->access_len, p); |
4ee9c684 | 120 | } |
121 | ||
60c514ba | 122 | if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0) |
4ee9c684 | 123 | { |
214b69f2 | 124 | if (u == NULL) |
125 | p = inquire_sequential (NULL, 0); | |
126 | else | |
2e1fa727 | 127 | switch (u->flags.access) |
128 | { | |
129 | case ACCESS_DIRECT: | |
130 | case ACCESS_STREAM: | |
ca4dd83f | 131 | p = no; |
2e1fa727 | 132 | break; |
133 | case ACCESS_SEQUENTIAL: | |
ca4dd83f | 134 | p = yes; |
2e1fa727 | 135 | break; |
136 | default: | |
137 | internal_error (&iqp->common, "inquire_via_unit(): Bad access"); | |
138 | } | |
4ee9c684 | 139 | |
60c514ba | 140 | cf_strcpy (iqp->sequential, iqp->sequential_len, p); |
4ee9c684 | 141 | } |
142 | ||
60c514ba | 143 | if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) |
4ee9c684 | 144 | { |
2e1fa727 | 145 | if (u == NULL) |
146 | p = inquire_direct (NULL, 0); | |
147 | else | |
148 | switch (u->flags.access) | |
149 | { | |
150 | case ACCESS_SEQUENTIAL: | |
151 | case ACCESS_STREAM: | |
ca4dd83f | 152 | p = no; |
2e1fa727 | 153 | break; |
154 | case ACCESS_DIRECT: | |
ca4dd83f | 155 | p = yes; |
2e1fa727 | 156 | break; |
157 | default: | |
158 | internal_error (&iqp->common, "inquire_via_unit(): Bad access"); | |
159 | } | |
4ee9c684 | 160 | |
60c514ba | 161 | cf_strcpy (iqp->direct, iqp->direct_len, p); |
4ee9c684 | 162 | } |
163 | ||
60c514ba | 164 | if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0) |
4ee9c684 | 165 | { |
166 | if (u == NULL) | |
167 | p = undefined; | |
168 | else | |
169 | switch (u->flags.form) | |
170 | { | |
171 | case FORM_FORMATTED: | |
172 | p = "FORMATTED"; | |
173 | break; | |
174 | case FORM_UNFORMATTED: | |
175 | p = "UNFORMATTED"; | |
176 | break; | |
177 | default: | |
60c514ba | 178 | internal_error (&iqp->common, "inquire_via_unit(): Bad form"); |
4ee9c684 | 179 | } |
180 | ||
60c514ba | 181 | cf_strcpy (iqp->form, iqp->form_len, p); |
4ee9c684 | 182 | } |
183 | ||
60c514ba | 184 | if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) |
4ee9c684 | 185 | { |
2e1fa727 | 186 | if (u == NULL) |
187 | p = inquire_formatted (NULL, 0); | |
188 | else | |
189 | switch (u->flags.form) | |
190 | { | |
191 | case FORM_FORMATTED: | |
ca4dd83f | 192 | p = yes; |
2e1fa727 | 193 | break; |
194 | case FORM_UNFORMATTED: | |
ca4dd83f | 195 | p = no; |
2e1fa727 | 196 | break; |
197 | default: | |
198 | internal_error (&iqp->common, "inquire_via_unit(): Bad form"); | |
199 | } | |
4ee9c684 | 200 | |
60c514ba | 201 | cf_strcpy (iqp->formatted, iqp->formatted_len, p); |
4ee9c684 | 202 | } |
203 | ||
60c514ba | 204 | if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) |
4ee9c684 | 205 | { |
2e1fa727 | 206 | if (u == NULL) |
207 | p = inquire_unformatted (NULL, 0); | |
208 | else | |
209 | switch (u->flags.form) | |
210 | { | |
211 | case FORM_FORMATTED: | |
ca4dd83f | 212 | p = no; |
2e1fa727 | 213 | break; |
214 | case FORM_UNFORMATTED: | |
ca4dd83f | 215 | p = yes; |
2e1fa727 | 216 | break; |
217 | default: | |
218 | internal_error (&iqp->common, "inquire_via_unit(): Bad form"); | |
219 | } | |
4ee9c684 | 220 | |
60c514ba | 221 | cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); |
4ee9c684 | 222 | } |
223 | ||
60c514ba | 224 | if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0) |
a8600d84 | 225 | /* F2018 (N2137) 12.10.2.26: If there is no connection, recl is |
226 | assigned the value -1. */ | |
227 | *iqp->recl_out = (u != NULL) ? u->recl : -1; | |
4ee9c684 | 228 | |
4d8ee55b | 229 | if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0) |
3c43c91f | 230 | *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0; |
4d8ee55b | 231 | |
60c514ba | 232 | if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0) |
f4bfed80 | 233 | { |
234 | /* This only makes sense in the context of DIRECT access. */ | |
235 | if (u != NULL && u->flags.access == ACCESS_DIRECT) | |
236 | *iqp->nextrec = u->last_record + 1; | |
237 | else | |
238 | *iqp->nextrec = 0; | |
239 | } | |
4ee9c684 | 240 | |
60c514ba | 241 | if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0) |
4ee9c684 | 242 | { |
8e327405 | 243 | if (u == NULL || u->flags.form != FORM_FORMATTED) |
4ee9c684 | 244 | p = undefined; |
245 | else | |
246 | switch (u->flags.blank) | |
247 | { | |
248 | case BLANK_NULL: | |
60c514ba | 249 | p = "NULL"; |
4ee9c684 | 250 | break; |
251 | case BLANK_ZERO: | |
252 | p = "ZERO"; | |
253 | break; | |
254 | default: | |
60c514ba | 255 | internal_error (&iqp->common, "inquire_via_unit(): Bad blank"); |
4ee9c684 | 256 | } |
257 | ||
60c514ba | 258 | cf_strcpy (iqp->blank, iqp->blank_len, p); |
4ee9c684 | 259 | } |
260 | ||
8e327405 | 261 | if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) |
262 | { | |
263 | if (u == NULL || u->flags.form != FORM_FORMATTED) | |
264 | p = undefined; | |
265 | else | |
266 | switch (u->flags.pad) | |
267 | { | |
268 | case PAD_YES: | |
ca4dd83f | 269 | p = yes; |
8e327405 | 270 | break; |
271 | case PAD_NO: | |
ca4dd83f | 272 | p = no; |
8e327405 | 273 | break; |
274 | default: | |
275 | internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); | |
276 | } | |
277 | ||
278 | cf_strcpy (iqp->pad, iqp->pad_len, p); | |
279 | } | |
280 | ||
0d72fa67 | 281 | if (cf & IOPARM_INQUIRE_HAS_FLAGS2) |
8e327405 | 282 | { |
b5d015e3 | 283 | GFC_INTEGER_4 cf2 = iqp->flags2; |
284 | ||
0d72fa67 | 285 | if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0) |
286 | { | |
287 | if (u == NULL || u->flags.form != FORM_FORMATTED) | |
288 | p = undefined; | |
289 | else | |
290 | switch (u->flags.encoding) | |
291 | { | |
292 | case ENCODING_DEFAULT: | |
293 | p = "UNKNOWN"; | |
294 | break; | |
295 | case ENCODING_UTF8: | |
296 | p = "UTF-8"; | |
297 | break; | |
298 | default: | |
299 | internal_error (&iqp->common, "inquire_via_unit(): Bad encoding"); | |
300 | } | |
301 | ||
302 | cf_strcpy (iqp->encoding, iqp->encoding_len, p); | |
303 | } | |
8e327405 | 304 | |
0d72fa67 | 305 | if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0) |
306 | { | |
307 | if (u == NULL || u->flags.form != FORM_FORMATTED) | |
308 | p = undefined; | |
309 | else | |
310 | switch (u->flags.decimal) | |
311 | { | |
312 | case DECIMAL_POINT: | |
313 | p = "POINT"; | |
314 | break; | |
315 | case DECIMAL_COMMA: | |
316 | p = "COMMA"; | |
317 | break; | |
318 | default: | |
319 | internal_error (&iqp->common, "inquire_via_unit(): Bad comma"); | |
320 | } | |
321 | ||
322 | cf_strcpy (iqp->decimal, iqp->decimal_len, p); | |
323 | } | |
8e327405 | 324 | |
0d72fa67 | 325 | if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0) |
326 | { | |
327 | if (u == NULL) | |
328 | p = undefined; | |
329 | else | |
0d72fa67 | 330 | { |
629c30bb | 331 | switch (u->flags.async) |
332 | { | |
333 | case ASYNC_YES: | |
334 | p = yes; | |
335 | break; | |
336 | case ASYNC_NO: | |
337 | p = no; | |
338 | break; | |
339 | default: | |
340 | internal_error (&iqp->common, "inquire_via_unit(): Bad async"); | |
341 | } | |
0d72fa67 | 342 | } |
85df3aea | 343 | cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p); |
3a7b4a0a | 344 | } |
345 | ||
629c30bb | 346 | if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0) |
347 | { | |
348 | if (!ASYNC_IO || u->au == NULL) | |
349 | *(iqp->pending) = 0; | |
350 | else | |
351 | { | |
352 | LOCK (&(u->au->lock)); | |
353 | if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0) | |
354 | { | |
355 | int id; | |
356 | id = *(iqp->id); | |
357 | *(iqp->pending) = id > u->au->id.low; | |
358 | } | |
359 | else | |
360 | { | |
361 | *(iqp->pending) = ! u->au->empty; | |
362 | } | |
363 | UNLOCK (&(u->au->lock)); | |
364 | } | |
365 | } | |
366 | ||
0d72fa67 | 367 | if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0) |
368 | { | |
369 | if (u == NULL) | |
370 | p = undefined; | |
371 | else | |
372 | switch (u->flags.sign) | |
373 | { | |
374 | case SIGN_PROCDEFINED: | |
375 | p = "PROCESSOR_DEFINED"; | |
376 | break; | |
377 | case SIGN_SUPPRESS: | |
378 | p = "SUPPRESS"; | |
379 | break; | |
380 | case SIGN_PLUS: | |
381 | p = "PLUS"; | |
382 | break; | |
383 | default: | |
384 | internal_error (&iqp->common, "inquire_via_unit(): Bad sign"); | |
385 | } | |
386 | ||
387 | cf_strcpy (iqp->sign, iqp->sign_len, p); | |
388 | } | |
8e327405 | 389 | |
0d72fa67 | 390 | if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0) |
391 | { | |
392 | if (u == NULL) | |
393 | p = undefined; | |
394 | else | |
395 | switch (u->flags.round) | |
396 | { | |
397 | case ROUND_UP: | |
398 | p = "UP"; | |
399 | break; | |
400 | case ROUND_DOWN: | |
401 | p = "DOWN"; | |
402 | break; | |
403 | case ROUND_ZERO: | |
404 | p = "ZERO"; | |
405 | break; | |
406 | case ROUND_NEAREST: | |
407 | p = "NEAREST"; | |
408 | break; | |
409 | case ROUND_COMPATIBLE: | |
410 | p = "COMPATIBLE"; | |
411 | break; | |
412 | case ROUND_PROCDEFINED: | |
413 | p = "PROCESSOR_DEFINED"; | |
414 | break; | |
415 | default: | |
416 | internal_error (&iqp->common, "inquire_via_unit(): Bad round"); | |
417 | } | |
418 | ||
419 | cf_strcpy (iqp->round, iqp->round_len, p); | |
420 | } | |
f4e9c676 | 421 | |
422 | if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0) | |
423 | { | |
424 | if (u == NULL) | |
425 | *iqp->size = -1; | |
426 | else | |
16b1d20f | 427 | { |
428 | sflush (u->s); | |
429 | *iqp->size = ssize (u->s); | |
430 | } | |
f4e9c676 | 431 | } |
983e427e | 432 | |
433 | if ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0) | |
434 | { | |
435 | if (u == NULL) | |
436 | p = "UNKNOWN"; | |
437 | else | |
438 | switch (u->flags.access) | |
439 | { | |
440 | case ACCESS_SEQUENTIAL: | |
441 | case ACCESS_DIRECT: | |
ca4dd83f | 442 | p = no; |
983e427e | 443 | break; |
444 | case ACCESS_STREAM: | |
ca4dd83f | 445 | p = yes; |
983e427e | 446 | break; |
447 | default: | |
448 | internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); | |
449 | } | |
450 | ||
451 | cf_strcpy (iqp->iqstream, iqp->iqstream_len, p); | |
452 | } | |
b3db57e8 | 453 | |
454 | if ((cf2 & IOPARM_INQUIRE_HAS_SHARE) != 0) | |
455 | { | |
456 | if (u == NULL) | |
457 | p = "UNKNOWN"; | |
458 | else | |
459 | switch (u->flags.share) | |
460 | { | |
461 | case SHARE_DENYRW: | |
462 | p = "DENYRW"; | |
463 | break; | |
464 | case SHARE_DENYNONE: | |
465 | p = "DENYNONE"; | |
466 | break; | |
467 | case SHARE_UNSPECIFIED: | |
468 | p = "NODENY"; | |
469 | break; | |
470 | default: | |
471 | internal_error (&iqp->common, | |
472 | "inquire_via_unit(): Bad share"); | |
473 | break; | |
474 | } | |
475 | ||
476 | cf_strcpy (iqp->share, iqp->share_len, p); | |
477 | } | |
478 | ||
479 | if ((cf2 & IOPARM_INQUIRE_HAS_CC) != 0) | |
480 | { | |
481 | if (u == NULL) | |
482 | p = "UNKNOWN"; | |
483 | else | |
484 | switch (u->flags.cc) | |
485 | { | |
486 | case CC_FORTRAN: | |
487 | p = "FORTRAN"; | |
488 | break; | |
489 | case CC_LIST: | |
490 | p = "LIST"; | |
491 | break; | |
492 | case CC_NONE: | |
493 | p = "NONE"; | |
494 | break; | |
495 | case CC_UNSPECIFIED: | |
496 | p = "UNKNOWN"; | |
497 | break; | |
498 | default: | |
499 | internal_error (&iqp->common, "inquire_via_unit(): Bad cc"); | |
500 | break; | |
501 | } | |
502 | ||
503 | cf_strcpy (iqp->cc, iqp->cc_len, p); | |
504 | } | |
8e327405 | 505 | } |
506 | ||
60c514ba | 507 | if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) |
4ee9c684 | 508 | { |
509 | if (u == NULL || u->flags.access == ACCESS_DIRECT) | |
b3b0377b | 510 | p = undefined; |
4ee9c684 | 511 | else |
68f57f43 | 512 | { |
513 | /* If the position is unspecified, check if we can figure | |
514 | out whether it's at the beginning or end. */ | |
515 | if (u->flags.position == POSITION_UNSPECIFIED) | |
516 | { | |
517 | gfc_offset cur = stell (u->s); | |
518 | if (cur == 0) | |
519 | u->flags.position = POSITION_REWIND; | |
520 | else if (cur != -1 && (ssize (u->s) == cur)) | |
521 | u->flags.position = POSITION_APPEND; | |
522 | } | |
523 | switch (u->flags.position) | |
524 | { | |
525 | case POSITION_REWIND: | |
526 | p = "REWIND"; | |
527 | break; | |
528 | case POSITION_APPEND: | |
529 | p = "APPEND"; | |
530 | break; | |
531 | case POSITION_ASIS: | |
532 | p = "ASIS"; | |
533 | break; | |
534 | default: | |
535 | /* If the position has changed and is not rewind or | |
536 | append, it must be set to a processor-dependent | |
537 | value. */ | |
538 | p = "UNSPECIFIED"; | |
539 | break; | |
540 | } | |
541 | } | |
60c514ba | 542 | cf_strcpy (iqp->position, iqp->position_len, p); |
4ee9c684 | 543 | } |
544 | ||
60c514ba | 545 | if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0) |
4ee9c684 | 546 | { |
547 | if (u == NULL) | |
548 | p = undefined; | |
549 | else | |
550 | switch (u->flags.action) | |
551 | { | |
552 | case ACTION_READ: | |
553 | p = "READ"; | |
554 | break; | |
555 | case ACTION_WRITE: | |
556 | p = "WRITE"; | |
557 | break; | |
558 | case ACTION_READWRITE: | |
559 | p = "READWRITE"; | |
560 | break; | |
561 | default: | |
60c514ba | 562 | internal_error (&iqp->common, "inquire_via_unit(): Bad action"); |
4ee9c684 | 563 | } |
564 | ||
60c514ba | 565 | cf_strcpy (iqp->action, iqp->action_len, p); |
4ee9c684 | 566 | } |
567 | ||
60c514ba | 568 | if ((cf & IOPARM_INQUIRE_HAS_READ) != 0) |
4ee9c684 | 569 | { |
ca4dd83f | 570 | p = (!u || u->flags.action == ACTION_WRITE) ? no : yes; |
60c514ba | 571 | cf_strcpy (iqp->read, iqp->read_len, p); |
4ee9c684 | 572 | } |
573 | ||
60c514ba | 574 | if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0) |
4ee9c684 | 575 | { |
ca4dd83f | 576 | p = (!u || u->flags.action == ACTION_READ) ? no : yes; |
60c514ba | 577 | cf_strcpy (iqp->write, iqp->write_len, p); |
4ee9c684 | 578 | } |
579 | ||
60c514ba | 580 | if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0) |
4ee9c684 | 581 | { |
ca4dd83f | 582 | p = (!u || u->flags.action != ACTION_READWRITE) ? no : yes; |
60c514ba | 583 | cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); |
4ee9c684 | 584 | } |
585 | ||
60c514ba | 586 | if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0) |
4ee9c684 | 587 | { |
588 | if (u == NULL || u->flags.form != FORM_FORMATTED) | |
589 | p = undefined; | |
590 | else | |
591 | switch (u->flags.delim) | |
592 | { | |
593 | case DELIM_NONE: | |
66757c26 | 594 | case DELIM_UNSPECIFIED: |
4ee9c684 | 595 | p = "NONE"; |
596 | break; | |
597 | case DELIM_QUOTE: | |
598 | p = "QUOTE"; | |
599 | break; | |
600 | case DELIM_APOSTROPHE: | |
601 | p = "APOSTROPHE"; | |
602 | break; | |
603 | default: | |
60c514ba | 604 | internal_error (&iqp->common, "inquire_via_unit(): Bad delim"); |
4ee9c684 | 605 | } |
606 | ||
60c514ba | 607 | cf_strcpy (iqp->delim, iqp->delim_len, p); |
4ee9c684 | 608 | } |
609 | ||
60c514ba | 610 | if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) |
4ee9c684 | 611 | { |
612 | if (u == NULL || u->flags.form != FORM_FORMATTED) | |
613 | p = undefined; | |
614 | else | |
615 | switch (u->flags.pad) | |
616 | { | |
617 | case PAD_NO: | |
ca4dd83f | 618 | p = no; |
4ee9c684 | 619 | break; |
620 | case PAD_YES: | |
ca4dd83f | 621 | p = yes; |
4ee9c684 | 622 | break; |
623 | default: | |
60c514ba | 624 | internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); |
4ee9c684 | 625 | } |
626 | ||
60c514ba | 627 | cf_strcpy (iqp->pad, iqp->pad_len, p); |
4ee9c684 | 628 | } |
9e94d29f | 629 | |
630 | if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0) | |
631 | { | |
632 | if (u == NULL) | |
633 | p = undefined; | |
634 | else | |
635 | switch (u->flags.convert) | |
636 | { | |
18f0b7df | 637 | case GFC_CONVERT_NATIVE: |
43938465 | 638 | p = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? "BIG_ENDIAN" : "LITTLE_ENDIAN"; |
9e94d29f | 639 | break; |
640 | ||
18f0b7df | 641 | case GFC_CONVERT_SWAP: |
43938465 | 642 | p = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? "LITTLE_ENDIAN" : "BIG_ENDIAN"; |
9e94d29f | 643 | break; |
644 | ||
645 | default: | |
646 | internal_error (&iqp->common, "inquire_via_unit(): Bad convert"); | |
647 | } | |
648 | ||
649 | cf_strcpy (iqp->convert, iqp->convert_len, p); | |
650 | } | |
4ee9c684 | 651 | } |
652 | ||
653 | ||
654 | /* inquire_via_filename()-- Inquiry via filename. This subroutine is | |
25a5ce27 | 655 | only used if the filename is *not* connected to a unit number. */ |
4ee9c684 | 656 | |
657 | static void | |
60c514ba | 658 | inquire_via_filename (st_parameter_inquire *iqp) |
4ee9c684 | 659 | { |
660 | const char *p; | |
60c514ba | 661 | GFC_INTEGER_4 cf = iqp->common.flags; |
4ee9c684 | 662 | |
60c514ba | 663 | if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) |
664 | *iqp->exist = file_exists (iqp->file, iqp->file_len); | |
4ee9c684 | 665 | |
60c514ba | 666 | if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) |
667 | *iqp->opened = 0; | |
4ee9c684 | 668 | |
60c514ba | 669 | if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0) |
670 | *iqp->number = -1; | |
4ee9c684 | 671 | |
60c514ba | 672 | if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0) |
673 | *iqp->named = 1; | |
4ee9c684 | 674 | |
60c514ba | 675 | if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0) |
676 | fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len); | |
4ee9c684 | 677 | |
60c514ba | 678 | if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) |
679 | cf_strcpy (iqp->access, iqp->access_len, undefined); | |
4ee9c684 | 680 | |
60c514ba | 681 | if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0) |
4ee9c684 | 682 | { |
2e1fa727 | 683 | p = "UNKNOWN"; |
60c514ba | 684 | cf_strcpy (iqp->sequential, iqp->sequential_len, p); |
4ee9c684 | 685 | } |
686 | ||
60c514ba | 687 | if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) |
4ee9c684 | 688 | { |
2e1fa727 | 689 | p = "UNKNOWN"; |
60c514ba | 690 | cf_strcpy (iqp->direct, iqp->direct_len, p); |
4ee9c684 | 691 | } |
692 | ||
60c514ba | 693 | if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0) |
694 | cf_strcpy (iqp->form, iqp->form_len, undefined); | |
4ee9c684 | 695 | |
60c514ba | 696 | if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) |
4ee9c684 | 697 | { |
2e1fa727 | 698 | p = "UNKNOWN"; |
60c514ba | 699 | cf_strcpy (iqp->formatted, iqp->formatted_len, p); |
4ee9c684 | 700 | } |
701 | ||
60c514ba | 702 | if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) |
4ee9c684 | 703 | { |
2e1fa727 | 704 | p = "UNKNOWN"; |
60c514ba | 705 | cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); |
4ee9c684 | 706 | } |
707 | ||
60c514ba | 708 | if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0) |
709 | *iqp->recl_out = 0; | |
4ee9c684 | 710 | |
60c514ba | 711 | if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0) |
712 | *iqp->nextrec = 0; | |
4ee9c684 | 713 | |
60c514ba | 714 | if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0) |
715 | cf_strcpy (iqp->blank, iqp->blank_len, undefined); | |
4ee9c684 | 716 | |
8e327405 | 717 | if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) |
718 | cf_strcpy (iqp->pad, iqp->pad_len, undefined); | |
719 | ||
0d72fa67 | 720 | if (cf & IOPARM_INQUIRE_HAS_FLAGS2) |
721 | { | |
b5d015e3 | 722 | GFC_INTEGER_4 cf2 = iqp->flags2; |
723 | ||
0d72fa67 | 724 | if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0) |
725 | cf_strcpy (iqp->encoding, iqp->encoding_len, undefined); | |
8e327405 | 726 | |
0d72fa67 | 727 | if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0) |
728 | cf_strcpy (iqp->delim, iqp->delim_len, undefined); | |
729 | ||
730 | if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0) | |
731 | cf_strcpy (iqp->decimal, iqp->decimal_len, undefined); | |
8e327405 | 732 | |
0d72fa67 | 733 | if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0) |
734 | cf_strcpy (iqp->delim, iqp->delim_len, undefined); | |
735 | ||
736 | if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0) | |
737 | cf_strcpy (iqp->pad, iqp->pad_len, undefined); | |
738 | ||
739 | if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0) | |
740 | cf_strcpy (iqp->encoding, iqp->encoding_len, undefined); | |
f4e9c676 | 741 | |
742 | if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0) | |
743 | *iqp->size = file_size (iqp->file, iqp->file_len); | |
983e427e | 744 | |
745 | if ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0) | |
746 | cf_strcpy (iqp->iqstream, iqp->iqstream_len, "UNKNOWN"); | |
b3db57e8 | 747 | |
748 | if ((cf2 & IOPARM_INQUIRE_HAS_SHARE) != 0) | |
749 | cf_strcpy (iqp->share, iqp->share_len, "UNKNOWN"); | |
750 | ||
751 | if ((cf2 & IOPARM_INQUIRE_HAS_CC) != 0) | |
752 | cf_strcpy (iqp->cc, iqp->cc_len, "UNKNOWN"); | |
0d72fa67 | 753 | } |
8e327405 | 754 | |
60c514ba | 755 | if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) |
756 | cf_strcpy (iqp->position, iqp->position_len, undefined); | |
4ee9c684 | 757 | |
60c514ba | 758 | if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) |
759 | cf_strcpy (iqp->access, iqp->access_len, undefined); | |
4ee9c684 | 760 | |
60c514ba | 761 | if ((cf & IOPARM_INQUIRE_HAS_READ) != 0) |
4ee9c684 | 762 | { |
60c514ba | 763 | p = inquire_read (iqp->file, iqp->file_len); |
764 | cf_strcpy (iqp->read, iqp->read_len, p); | |
4ee9c684 | 765 | } |
766 | ||
60c514ba | 767 | if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0) |
4ee9c684 | 768 | { |
60c514ba | 769 | p = inquire_write (iqp->file, iqp->file_len); |
770 | cf_strcpy (iqp->write, iqp->write_len, p); | |
4ee9c684 | 771 | } |
772 | ||
60c514ba | 773 | if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0) |
4ee9c684 | 774 | { |
60c514ba | 775 | p = inquire_read (iqp->file, iqp->file_len); |
776 | cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); | |
4ee9c684 | 777 | } |
4ee9c684 | 778 | } |
779 | ||
780 | ||
6799e2f8 | 781 | /* Library entry point for the INQUIRE statement (non-IOLENGTH |
782 | form). */ | |
4ee9c684 | 783 | |
60c514ba | 784 | extern void st_inquire (st_parameter_inquire *); |
7b6cb5bd | 785 | export_proto(st_inquire); |
786 | ||
4ee9c684 | 787 | void |
60c514ba | 788 | st_inquire (st_parameter_inquire *iqp) |
4ee9c684 | 789 | { |
f02dd226 | 790 | gfc_unit *u; |
4ee9c684 | 791 | |
60c514ba | 792 | library_start (&iqp->common); |
4ee9c684 | 793 | |
60c514ba | 794 | if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0) |
795 | { | |
796 | u = find_unit (iqp->common.unit); | |
797 | inquire_via_unit (iqp, u); | |
798 | } | |
4ee9c684 | 799 | else |
800 | { | |
60c514ba | 801 | u = find_file (iqp->file, iqp->file_len); |
4ee9c684 | 802 | if (u == NULL) |
60c514ba | 803 | inquire_via_filename (iqp); |
4ee9c684 | 804 | else |
60c514ba | 805 | inquire_via_unit (iqp, u); |
4ee9c684 | 806 | } |
60c514ba | 807 | if (u != NULL) |
808 | unlock_unit (u); | |
4ee9c684 | 809 | |
810 | library_end (); | |
811 | } |