]>
Commit | Line | Data |
---|---|---|
7b7034ea | 1 | /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. |
6de9cd9a | 2 | Contributed by Andy Vaught |
29dc5138 | 3 | Namelist transfer functions contributed by Paul Thomas |
6de9cd9a DN |
4 | |
5 | This file is part of the GNU Fortran 95 runtime library (libgfortran). | |
6 | ||
7 | Libgfortran is free software; you can redistribute it and/or modify | |
8 | it under the terms of the GNU General Public License as published by | |
9 | the Free Software Foundation; either version 2, or (at your option) | |
10 | any later version. | |
11 | ||
57dea9f6 TM |
12 | In addition to the permissions in the GNU General Public License, the |
13 | Free Software Foundation gives you unlimited permission to link the | |
14 | compiled version of this file into combinations with other programs, | |
15 | and to distribute those combinations without any restriction coming | |
16 | from the use of this file. (The General Public License restrictions | |
17 | do apply in other respects; for example, they cover modification of | |
18 | the file, and distribution when not linked into a combine | |
19 | executable.) | |
20 | ||
6de9cd9a DN |
21 | Libgfortran is distributed in the hope that it will be useful, |
22 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
23 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
24 | GNU General Public License for more details. | |
25 | ||
26 | You should have received a copy of the GNU General Public License | |
27 | along with Libgfortran; see the file COPYING. If not, write to | |
fe2ae685 KC |
28 | the Free Software Foundation, 51 Franklin Street, Fifth Floor, |
29 | Boston, MA 02110-1301, USA. */ | |
6de9cd9a DN |
30 | |
31 | ||
7fcb1804 | 32 | /* transfer.c -- Top level handling of data transfer statements. */ |
6de9cd9a DN |
33 | |
34 | #include "config.h" | |
35 | #include <string.h> | |
3bc268e6 | 36 | #include <assert.h> |
6de9cd9a DN |
37 | #include "libgfortran.h" |
38 | #include "io.h" | |
39 | ||
40 | ||
41 | /* Calling conventions: Data transfer statements are unlike other | |
7fcb1804 TS |
42 | library calls in that they extend over several calls. |
43 | ||
44 | The first call is always a call to st_read() or st_write(). These | |
45 | subroutines return no status unless a namelist read or write is | |
46 | being done, in which case there is the usual status. No further | |
47 | calls are necessary in this case. | |
48 | ||
49 | For other sorts of data transfer, there are zero or more data | |
50 | transfer statement that depend on the format of the data transfer | |
51 | statement. | |
52 | ||
53 | transfer_integer | |
54 | transfer_logical | |
55 | transfer_character | |
56 | transfer_real | |
57 | transfer_complex | |
58 | ||
59 | These subroutines do not return status. | |
60 | ||
61 | The last call is a call to st_[read|write]_done(). While | |
62 | something can easily go wrong with the initial st_read() or | |
63 | st_write(), an error inhibits any data from actually being | |
64 | transferred. */ | |
6de9cd9a | 65 | |
5e805e44 | 66 | extern void transfer_integer (st_parameter_dt *, void *, int); |
7d7b8bfe RH |
67 | export_proto(transfer_integer); |
68 | ||
5e805e44 | 69 | extern void transfer_real (st_parameter_dt *, void *, int); |
7d7b8bfe RH |
70 | export_proto(transfer_real); |
71 | ||
5e805e44 | 72 | extern void transfer_logical (st_parameter_dt *, void *, int); |
7d7b8bfe RH |
73 | export_proto(transfer_logical); |
74 | ||
5e805e44 | 75 | extern void transfer_character (st_parameter_dt *, void *, int); |
7d7b8bfe RH |
76 | export_proto(transfer_character); |
77 | ||
5e805e44 | 78 | extern void transfer_complex (st_parameter_dt *, void *, int); |
7d7b8bfe RH |
79 | export_proto(transfer_complex); |
80 | ||
5e805e44 JJ |
81 | extern void transfer_array (st_parameter_dt *, gfc_array_char *, int, |
82 | gfc_charlen_type); | |
18623fae JB |
83 | export_proto(transfer_array); |
84 | ||
09003779 | 85 | static const st_option advance_opt[] = { |
6de9cd9a DN |
86 | {"yes", ADVANCE_YES}, |
87 | {"no", ADVANCE_NO}, | |
4b6903ec | 88 | {NULL, 0} |
6de9cd9a DN |
89 | }; |
90 | ||
91 | ||
6de9cd9a DN |
92 | typedef enum |
93 | { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, | |
94 | FORMATTED_DIRECT, UNFORMATTED_DIRECT | |
95 | } | |
96 | file_mode; | |
97 | ||
98 | ||
99 | static file_mode | |
5e805e44 | 100 | current_mode (st_parameter_dt *dtp) |
6de9cd9a DN |
101 | { |
102 | file_mode m; | |
103 | ||
5e805e44 | 104 | if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) |
6de9cd9a | 105 | { |
5e805e44 | 106 | m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? |
6de9cd9a DN |
107 | FORMATTED_DIRECT : UNFORMATTED_DIRECT; |
108 | } | |
109 | else | |
110 | { | |
5e805e44 | 111 | m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? |
6de9cd9a DN |
112 | FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL; |
113 | } | |
114 | ||
115 | return m; | |
116 | } | |
117 | ||
118 | ||
119 | /* Mid level data transfer statements. These subroutines do reading | |
7fcb1804 TS |
120 | and writing in the style of salloc_r()/salloc_w() within the |
121 | current record. */ | |
122 | ||
123 | /* When reading sequential formatted records we have a problem. We | |
124 | don't know how long the line is until we read the trailing newline, | |
125 | and we don't want to read too much. If we read too much, we might | |
126 | have to do a physical seek backwards depending on how much data is | |
127 | present, and devices like terminals aren't seekable and would cause | |
128 | an I/O error. | |
129 | ||
130 | Given this, the solution is to read a byte at a time, stopping if | |
131 | we hit the newline. For small locations, we use a static buffer. | |
132 | For larger allocations, we are forced to allocate memory on the | |
133 | heap. Hopefully this won't happen very often. */ | |
6de9cd9a DN |
134 | |
135 | static char * | |
5e805e44 | 136 | read_sf (st_parameter_dt *dtp, int *length) |
6de9cd9a | 137 | { |
6de9cd9a | 138 | char *base, *p, *q; |
8824fd4c FXC |
139 | int n, readlen, crlf; |
140 | gfc_offset pos; | |
6de9cd9a DN |
141 | |
142 | if (*length > SCRATCH_SIZE) | |
5e805e44 JJ |
143 | dtp->u.p.line_buffer = get_mem (*length); |
144 | p = base = dtp->u.p.line_buffer; | |
6de9cd9a | 145 | |
59afe4b4 TK |
146 | /* If we have seen an eor previously, return a length of 0. The |
147 | caller is responsible for correctly padding the input field. */ | |
5e805e44 | 148 | if (dtp->u.p.sf_seen_eor) |
59afe4b4 TK |
149 | { |
150 | *length = 0; | |
151 | return base; | |
152 | } | |
6de9cd9a | 153 | |
bd72d66c | 154 | readlen = 1; |
6de9cd9a DN |
155 | n = 0; |
156 | ||
157 | do | |
158 | { | |
5e805e44 | 159 | if (is_internal_unit (dtp)) |
be0cc7e2 | 160 | { |
420aa7b8 | 161 | /* readlen may be modified inside salloc_r if |
5e805e44 | 162 | is_internal_unit (dtp) is true. */ |
be0cc7e2 PT |
163 | readlen = 1; |
164 | } | |
6de9cd9a | 165 | |
5e805e44 | 166 | q = salloc_r (dtp->u.p.current_unit->s, &readlen); |
6de9cd9a DN |
167 | if (q == NULL) |
168 | break; | |
169 | ||
bd72d66c PB |
170 | /* If we have a line without a terminating \n, drop through to |
171 | EOR below. */ | |
681b5028 | 172 | if (readlen < 1 && n == 0) |
6de9cd9a | 173 | { |
5e805e44 | 174 | generate_error (&dtp->common, ERROR_END, NULL); |
bd72d66c PB |
175 | return NULL; |
176 | } | |
177 | ||
94887ef4 | 178 | if (readlen < 1 || *q == '\n' || *q == '\r') |
bd72d66c | 179 | { |
7fcb1804 | 180 | /* Unexpected end of line. */ |
59afe4b4 TK |
181 | |
182 | /* If we see an EOR during non-advancing I/O, we need to skip | |
183 | the rest of the I/O statement. Set the corresponding flag. */ | |
5e805e44 JJ |
184 | if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) |
185 | dtp->u.p.eor_condition = 1; | |
59afe4b4 | 186 | |
8824fd4c FXC |
187 | crlf = 0; |
188 | /* If we encounter a CR, it might be a CRLF. */ | |
189 | if (*q == '\r') /* Probably a CRLF */ | |
190 | { | |
191 | readlen = 1; | |
192 | pos = stream_offset (dtp->u.p.current_unit->s); | |
193 | q = salloc_r (dtp->u.p.current_unit->s, &readlen); | |
194 | if (*q != '\n' && readlen == 1) /* Not a CRLF after all. */ | |
195 | sseek (dtp->u.p.current_unit->s, pos); | |
196 | else | |
197 | crlf = 1; | |
198 | } | |
199 | ||
59afe4b4 TK |
200 | /* Without padding, terminate the I/O statement without assigning |
201 | the value. With padding, the value still needs to be assigned, | |
202 | so we can just continue with a short read. */ | |
5e805e44 | 203 | if (dtp->u.p.current_unit->flags.pad == PAD_NO) |
6de9cd9a | 204 | { |
5e805e44 | 205 | generate_error (&dtp->common, ERROR_EOR, NULL); |
6de9cd9a DN |
206 | return NULL; |
207 | } | |
208 | ||
6de9cd9a | 209 | *length = n; |
8824fd4c | 210 | dtp->u.p.sf_seen_eor = (crlf ? 2 : 1); |
6de9cd9a DN |
211 | break; |
212 | } | |
b14c7e14 JD |
213 | /* Short circuit the read if a comma is found during numeric input. |
214 | The flag is set to zero during character reads so that commas in | |
215 | strings are not ignored */ | |
216 | if (*q == ',') | |
217 | if (dtp->u.p.sf_read_comma == 1) | |
218 | { | |
219 | notify_std (GFC_STD_GNU, "Comma in formatted numeric read."); | |
220 | *length = n; | |
221 | break; | |
222 | } | |
6de9cd9a DN |
223 | |
224 | n++; | |
225 | *p++ = *q; | |
5e805e44 | 226 | dtp->u.p.sf_seen_eor = 0; |
6de9cd9a DN |
227 | } |
228 | while (n < *length); | |
5e805e44 | 229 | dtp->u.p.current_unit->bytes_left -= *length; |
6de9cd9a | 230 | |
5e805e44 JJ |
231 | if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) |
232 | *dtp->size += *length; | |
59afe4b4 | 233 | |
6de9cd9a DN |
234 | return base; |
235 | } | |
236 | ||
237 | ||
7fcb1804 TS |
238 | /* Function for reading the next couple of bytes from the current |
239 | file, advancing the current position. We return a pointer to a | |
240 | buffer containing the bytes. We return NULL on end of record or | |
241 | end of file. | |
420aa7b8 | 242 | |
7fcb1804 TS |
243 | If the read is short, then it is because the current record does not |
244 | have enough data to satisfy the read request and the file was | |
245 | opened with PAD=YES. The caller must assume tailing spaces for | |
246 | short reads. */ | |
6de9cd9a DN |
247 | |
248 | void * | |
5e805e44 | 249 | read_block (st_parameter_dt *dtp, int *length) |
6de9cd9a DN |
250 | { |
251 | char *source; | |
252 | int nread; | |
253 | ||
5e805e44 | 254 | if (dtp->u.p.current_unit->bytes_left < *length) |
6de9cd9a | 255 | { |
5e805e44 | 256 | if (dtp->u.p.current_unit->flags.pad == PAD_NO) |
6de9cd9a | 257 | { |
5e805e44 JJ |
258 | generate_error (&dtp->common, ERROR_EOR, NULL); |
259 | /* Not enough data left. */ | |
6de9cd9a DN |
260 | return NULL; |
261 | } | |
262 | ||
5e805e44 | 263 | *length = dtp->u.p.current_unit->bytes_left; |
6de9cd9a | 264 | } |
965eec16 | 265 | |
5e805e44 JJ |
266 | if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && |
267 | dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) | |
268 | return read_sf (dtp, length); /* Special case. */ | |
6de9cd9a | 269 | |
5e805e44 | 270 | dtp->u.p.current_unit->bytes_left -= *length; |
6de9cd9a DN |
271 | |
272 | nread = *length; | |
5e805e44 | 273 | source = salloc_r (dtp->u.p.current_unit->s, &nread); |
6de9cd9a | 274 | |
5e805e44 JJ |
275 | if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) |
276 | *dtp->size += nread; | |
6de9cd9a DN |
277 | |
278 | if (nread != *length) | |
7fcb1804 | 279 | { /* Short read, this shouldn't happen. */ |
5e805e44 | 280 | if (dtp->u.p.current_unit->flags.pad == PAD_YES) |
6de9cd9a DN |
281 | *length = nread; |
282 | else | |
283 | { | |
5e805e44 | 284 | generate_error (&dtp->common, ERROR_EOR, NULL); |
6de9cd9a DN |
285 | source = NULL; |
286 | } | |
287 | } | |
288 | ||
289 | return source; | |
290 | } | |
291 | ||
292 | ||
0dc43461 JB |
293 | /* Reads a block directly into application data space. */ |
294 | ||
295 | static void | |
5e805e44 | 296 | read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) |
0dc43461 JB |
297 | { |
298 | int *length; | |
299 | void *data; | |
300 | size_t nread; | |
301 | ||
5e805e44 | 302 | if (dtp->u.p.current_unit->bytes_left < *nbytes) |
0dc43461 | 303 | { |
5e805e44 | 304 | if (dtp->u.p.current_unit->flags.pad == PAD_NO) |
0dc43461 | 305 | { |
5e805e44 JJ |
306 | /* Not enough data left. */ |
307 | generate_error (&dtp->common, ERROR_EOR, NULL); | |
0dc43461 JB |
308 | return; |
309 | } | |
310 | ||
5e805e44 | 311 | *nbytes = dtp->u.p.current_unit->bytes_left; |
0dc43461 JB |
312 | } |
313 | ||
5e805e44 JJ |
314 | if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && |
315 | dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) | |
835681c8 | 316 | { |
5e805e44 JJ |
317 | length = (int *) nbytes; |
318 | data = read_sf (dtp, length); /* Special case. */ | |
835681c8 JD |
319 | memcpy (buf, data, (size_t) *length); |
320 | return; | |
321 | } | |
322 | ||
5e805e44 | 323 | dtp->u.p.current_unit->bytes_left -= *nbytes; |
0dc43461 JB |
324 | |
325 | nread = *nbytes; | |
5e805e44 | 326 | if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0) |
0dc43461 | 327 | { |
5e805e44 | 328 | generate_error (&dtp->common, ERROR_OS, NULL); |
0dc43461 JB |
329 | return; |
330 | } | |
331 | ||
5e805e44 JJ |
332 | if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) |
333 | *dtp->size += (GFC_INTEGER_4) nread; | |
0dc43461 JB |
334 | |
335 | if (nread != *nbytes) | |
336 | { /* Short read, e.g. if we hit EOF. */ | |
5e805e44 | 337 | if (dtp->u.p.current_unit->flags.pad == PAD_YES) |
0dc43461 JB |
338 | { |
339 | memset (((char *) buf) + nread, ' ', *nbytes - nread); | |
340 | *nbytes = nread; | |
341 | } | |
342 | else | |
5e805e44 | 343 | generate_error (&dtp->common, ERROR_EOR, NULL); |
0dc43461 JB |
344 | } |
345 | } | |
346 | ||
347 | ||
7fcb1804 TS |
348 | /* Function for writing a block of bytes to the current file at the |
349 | current position, advancing the file pointer. We are given a length | |
350 | and return a pointer to a buffer that the caller must (completely) | |
351 | fill in. Returns NULL on error. */ | |
6de9cd9a DN |
352 | |
353 | void * | |
5e805e44 | 354 | write_block (st_parameter_dt *dtp, int length) |
6de9cd9a DN |
355 | { |
356 | char *dest; | |
59154ed2 | 357 | |
5e805e44 | 358 | if (dtp->u.p.current_unit->bytes_left < length) |
6de9cd9a | 359 | { |
5e805e44 | 360 | generate_error (&dtp->common, ERROR_EOR, NULL); |
6de9cd9a DN |
361 | return NULL; |
362 | } | |
363 | ||
5e805e44 JJ |
364 | dtp->u.p.current_unit->bytes_left -= (gfc_offset) length; |
365 | dest = salloc_w (dtp->u.p.current_unit->s, &length); | |
aed6ee24 JD |
366 | |
367 | if (dest == NULL) | |
368 | { | |
5e805e44 | 369 | generate_error (&dtp->common, ERROR_END, NULL); |
aed6ee24 JD |
370 | return NULL; |
371 | } | |
6de9cd9a | 372 | |
5e805e44 JJ |
373 | if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) |
374 | *dtp->size += length; | |
6de9cd9a DN |
375 | |
376 | return dest; | |
377 | } | |
378 | ||
379 | ||
82b8244c | 380 | /* High level interface to swrite(), taking care of errors. */ |
0dc43461 | 381 | |
82b8244c JB |
382 | static try |
383 | write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) | |
0dc43461 | 384 | { |
82b8244c JB |
385 | if (dtp->u.p.current_unit->bytes_left < nbytes) |
386 | { | |
54f9e278 JD |
387 | if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) |
388 | generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL); | |
389 | else | |
390 | generate_error (&dtp->common, ERROR_EOR, NULL); | |
82b8244c JB |
391 | return FAILURE; |
392 | } | |
0dc43461 | 393 | |
82b8244c | 394 | dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes; |
0dc43461 | 395 | |
82b8244c JB |
396 | if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0) |
397 | { | |
398 | generate_error (&dtp->common, ERROR_OS, NULL); | |
399 | return FAILURE; | |
400 | } | |
0dc43461 | 401 | |
5e805e44 | 402 | if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) |
82b8244c JB |
403 | { |
404 | *dtp->size += (GFC_INTEGER_4) nbytes; | |
405 | return FAILURE; | |
406 | } | |
407 | ||
408 | return SUCCESS; | |
0dc43461 JB |
409 | } |
410 | ||
411 | ||
7fcb1804 | 412 | /* Master function for unformatted reads. */ |
6de9cd9a DN |
413 | |
414 | static void | |
181c9f4a TK |
415 | unformatted_read (st_parameter_dt *dtp, bt type, |
416 | void *dest, int kind, | |
5e805e44 | 417 | size_t size, size_t nelems) |
6de9cd9a | 418 | { |
181c9f4a TK |
419 | /* Currently, character implies size=1. */ |
420 | if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE | |
421 | || size == 1 || type == BT_CHARACTER) | |
422 | { | |
423 | size *= nelems; | |
424 | read_block_direct (dtp, dest, &size); | |
425 | } | |
426 | else | |
427 | { | |
428 | char buffer[16]; | |
429 | char *p; | |
430 | size_t i, sz; | |
431 | ||
432 | /* Break up complex into its constituent reals. */ | |
433 | if (type == BT_COMPLEX) | |
434 | { | |
435 | nelems *= 2; | |
436 | size /= 2; | |
437 | } | |
438 | p = dest; | |
439 | ||
440 | /* By now, all complex variables have been split into their | |
441 | constituent reals. For types with padding, we only need to | |
442 | read kind bytes. We don't care about the contents | |
443 | of the padding. */ | |
444 | ||
445 | sz = kind; | |
446 | for (i=0; i<nelems; i++) | |
447 | { | |
448 | read_block_direct (dtp, buffer, &sz); | |
449 | reverse_memcpy (p, buffer, sz); | |
450 | p += size; | |
451 | } | |
452 | } | |
6de9cd9a DN |
453 | } |
454 | ||
0dc43461 | 455 | |
7fcb1804 TS |
456 | /* Master function for unformatted writes. */ |
457 | ||
6de9cd9a | 458 | static void |
181c9f4a TK |
459 | unformatted_write (st_parameter_dt *dtp, bt type, |
460 | void *source, int kind, | |
5e805e44 | 461 | size_t size, size_t nelems) |
6de9cd9a | 462 | { |
181c9f4a TK |
463 | if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE || |
464 | size == 1 || type == BT_CHARACTER) | |
465 | { | |
466 | size *= nelems; | |
467 | ||
82b8244c | 468 | write_buf (dtp, source, size); |
181c9f4a TK |
469 | } |
470 | else | |
471 | { | |
472 | char buffer[16]; | |
473 | char *p; | |
474 | size_t i, sz; | |
475 | ||
476 | /* Break up complex into its constituent reals. */ | |
477 | if (type == BT_COMPLEX) | |
478 | { | |
479 | nelems *= 2; | |
480 | size /= 2; | |
481 | } | |
482 | ||
483 | p = source; | |
abd7fea9 | 484 | |
181c9f4a TK |
485 | /* By now, all complex variables have been split into their |
486 | constituent reals. For types with padding, we only need to | |
487 | read kind bytes. We don't care about the contents | |
488 | of the padding. */ | |
489 | ||
490 | sz = kind; | |
491 | for (i=0; i<nelems; i++) | |
492 | { | |
493 | reverse_memcpy(buffer, p, size); | |
494 | p+= size; | |
82b8244c | 495 | write_buf (dtp, buffer, sz); |
181c9f4a TK |
496 | } |
497 | } | |
6de9cd9a DN |
498 | } |
499 | ||
500 | ||
7fcb1804 | 501 | /* Return a pointer to the name of a type. */ |
6de9cd9a DN |
502 | |
503 | const char * | |
504 | type_name (bt type) | |
505 | { | |
506 | const char *p; | |
507 | ||
508 | switch (type) | |
509 | { | |
510 | case BT_INTEGER: | |
511 | p = "INTEGER"; | |
512 | break; | |
513 | case BT_LOGICAL: | |
514 | p = "LOGICAL"; | |
515 | break; | |
516 | case BT_CHARACTER: | |
517 | p = "CHARACTER"; | |
518 | break; | |
519 | case BT_REAL: | |
520 | p = "REAL"; | |
521 | break; | |
522 | case BT_COMPLEX: | |
523 | p = "COMPLEX"; | |
524 | break; | |
525 | default: | |
5e805e44 | 526 | internal_error (NULL, "type_name(): Bad type"); |
6de9cd9a DN |
527 | } |
528 | ||
529 | return p; | |
530 | } | |
531 | ||
532 | ||
7fcb1804 TS |
533 | /* Write a constant string to the output. |
534 | This is complicated because the string can have doubled delimiters | |
535 | in it. The length in the format node is the true length. */ | |
6de9cd9a DN |
536 | |
537 | static void | |
5e805e44 | 538 | write_constant_string (st_parameter_dt *dtp, const fnode *f) |
6de9cd9a DN |
539 | { |
540 | char c, delimiter, *p, *q; | |
541 | int length; | |
542 | ||
543 | length = f->u.string.length; | |
544 | if (length == 0) | |
545 | return; | |
546 | ||
5e805e44 | 547 | p = write_block (dtp, length); |
6de9cd9a DN |
548 | if (p == NULL) |
549 | return; | |
550 | ||
551 | q = f->u.string.p; | |
552 | delimiter = q[-1]; | |
553 | ||
554 | for (; length > 0; length--) | |
555 | { | |
556 | c = *p++ = *q++; | |
ec88bf8b | 557 | if (c == delimiter && c != 'H' && c != 'h') |
7fcb1804 | 558 | q++; /* Skip the doubled delimiter. */ |
6de9cd9a DN |
559 | } |
560 | } | |
561 | ||
562 | ||
7fcb1804 TS |
563 | /* Given actual and expected types in a formatted data transfer, make |
564 | sure they agree. If not, an error message is generated. Returns | |
565 | nonzero if something went wrong. */ | |
6de9cd9a DN |
566 | |
567 | static int | |
5e805e44 | 568 | require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) |
6de9cd9a DN |
569 | { |
570 | char buffer[100]; | |
571 | ||
572 | if (actual == expected) | |
573 | return 0; | |
574 | ||
575 | st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", | |
5e805e44 | 576 | type_name (expected), dtp->u.p.item_count, type_name (actual)); |
6de9cd9a | 577 | |
5e805e44 | 578 | format_error (dtp, f, buffer); |
6de9cd9a DN |
579 | return 1; |
580 | } | |
581 | ||
582 | ||
7fcb1804 TS |
583 | /* This subroutine is the main loop for a formatted data transfer |
584 | statement. It would be natural to implement this as a coroutine | |
585 | with the user program, but C makes that awkward. We loop, | |
586 | processesing format elements. When we actually have to transfer | |
587 | data instead of just setting flags, we return control to the user | |
588 | program which calls a subroutine that supplies the address and type | |
589 | of the next element, then comes back here to process it. */ | |
6de9cd9a DN |
590 | |
591 | static void | |
5e805e44 JJ |
592 | formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len, |
593 | size_t size) | |
6de9cd9a | 594 | { |
5e805e44 | 595 | char scratch[SCRATCH_SIZE]; |
94e2b58a | 596 | int pos, bytes_used; |
5e805e44 | 597 | const fnode *f; |
be0cc7e2 | 598 | format_token t; |
a3b6aba2 | 599 | int n; |
6de9cd9a DN |
600 | int consume_data_flag; |
601 | ||
7fcb1804 | 602 | /* Change a complex data item into a pair of reals. */ |
6de9cd9a DN |
603 | |
604 | n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2); | |
605 | if (type == BT_COMPLEX) | |
e5ef4b3b JB |
606 | { |
607 | type = BT_REAL; | |
608 | size /= 2; | |
609 | } | |
6de9cd9a | 610 | |
59afe4b4 TK |
611 | /* If there's an EOR condition, we simulate finalizing the transfer |
612 | by doing nothing. */ | |
5e805e44 | 613 | if (dtp->u.p.eor_condition) |
59afe4b4 TK |
614 | return; |
615 | ||
b14c7e14 JD |
616 | /* Set this flag so that commas in reads cause the read to complete before |
617 | the entire field has been read. The next read field will start right after | |
618 | the comma in the stream. (Set to 0 for character reads). */ | |
619 | dtp->u.p.sf_read_comma = 1; | |
620 | ||
5e805e44 | 621 | dtp->u.p.line_buffer = scratch; |
6de9cd9a DN |
622 | for (;;) |
623 | { | |
5d3a9816 | 624 | /* If reversion has occurred and there is another real data item, |
be0cc7e2 | 625 | then we have to move to the next record. */ |
5e805e44 | 626 | if (dtp->u.p.reversion_flag && n > 0) |
be0cc7e2 | 627 | { |
5e805e44 JJ |
628 | dtp->u.p.reversion_flag = 0; |
629 | next_record (dtp, 0); | |
be0cc7e2 | 630 | } |
5d3a9816 | 631 | |
6de9cd9a | 632 | consume_data_flag = 1 ; |
5e805e44 | 633 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a DN |
634 | break; |
635 | ||
5e805e44 | 636 | f = next_format (dtp); |
6de9cd9a | 637 | if (f == NULL) |
be0cc7e2 PT |
638 | return; /* No data descriptors left (already raised). */ |
639 | ||
640 | /* Now discharge T, TR and X movements to the right. This is delayed | |
b6f571b7 | 641 | until a data producing format to suppress trailing spaces. */ |
740f04ef | 642 | |
be0cc7e2 | 643 | t = f->format; |
5e805e44 | 644 | if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0 |
b6f571b7 PT |
645 | && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O |
646 | || t == FMT_Z || t == FMT_F || t == FMT_E | |
647 | || t == FMT_EN || t == FMT_ES || t == FMT_G | |
648 | || t == FMT_L || t == FMT_A || t == FMT_D)) | |
be0cc7e2 PT |
649 | || t == FMT_STRING)) |
650 | { | |
5e805e44 | 651 | if (dtp->u.p.skips > 0) |
b6f571b7 | 652 | { |
5e805e44 JJ |
653 | write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); |
654 | dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl | |
655 | - dtp->u.p.current_unit->bytes_left); | |
b6f571b7 | 656 | } |
5e805e44 | 657 | if (dtp->u.p.skips < 0) |
b6f571b7 | 658 | { |
5e805e44 JJ |
659 | move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips); |
660 | dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; | |
b6f571b7 | 661 | } |
5e805e44 | 662 | dtp->u.p.skips = dtp->u.p.pending_spaces = 0; |
be0cc7e2 | 663 | } |
6de9cd9a | 664 | |
5e805e44 | 665 | bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); |
94e2b58a | 666 | |
be0cc7e2 | 667 | switch (t) |
6de9cd9a DN |
668 | { |
669 | case FMT_I: | |
670 | if (n == 0) | |
671 | goto need_data; | |
5e805e44 | 672 | if (require_type (dtp, BT_INTEGER, type, f)) |
6de9cd9a DN |
673 | return; |
674 | ||
5e805e44 JJ |
675 | if (dtp->u.p.mode == READING) |
676 | read_decimal (dtp, f, p, len); | |
6de9cd9a | 677 | else |
5e805e44 | 678 | write_i (dtp, f, p, len); |
6de9cd9a DN |
679 | |
680 | break; | |
681 | ||
682 | case FMT_B: | |
683 | if (n == 0) | |
684 | goto need_data; | |
5e805e44 | 685 | if (require_type (dtp, BT_INTEGER, type, f)) |
6de9cd9a DN |
686 | return; |
687 | ||
5e805e44 JJ |
688 | if (dtp->u.p.mode == READING) |
689 | read_radix (dtp, f, p, len, 2); | |
6de9cd9a | 690 | else |
5e805e44 | 691 | write_b (dtp, f, p, len); |
6de9cd9a DN |
692 | |
693 | break; | |
694 | ||
695 | case FMT_O: | |
696 | if (n == 0) | |
697 | goto need_data; | |
698 | ||
5e805e44 JJ |
699 | if (dtp->u.p.mode == READING) |
700 | read_radix (dtp, f, p, len, 8); | |
6de9cd9a | 701 | else |
5e805e44 | 702 | write_o (dtp, f, p, len); |
6de9cd9a DN |
703 | |
704 | break; | |
705 | ||
706 | case FMT_Z: | |
707 | if (n == 0) | |
708 | goto need_data; | |
709 | ||
5e805e44 JJ |
710 | if (dtp->u.p.mode == READING) |
711 | read_radix (dtp, f, p, len, 16); | |
6de9cd9a | 712 | else |
5e805e44 | 713 | write_z (dtp, f, p, len); |
6de9cd9a DN |
714 | |
715 | break; | |
716 | ||
717 | case FMT_A: | |
718 | if (n == 0) | |
719 | goto need_data; | |
6de9cd9a | 720 | |
5e805e44 JJ |
721 | if (dtp->u.p.mode == READING) |
722 | read_a (dtp, f, p, len); | |
6de9cd9a | 723 | else |
5e805e44 | 724 | write_a (dtp, f, p, len); |
6de9cd9a DN |
725 | |
726 | break; | |
727 | ||
728 | case FMT_L: | |
729 | if (n == 0) | |
730 | goto need_data; | |
731 | ||
5e805e44 JJ |
732 | if (dtp->u.p.mode == READING) |
733 | read_l (dtp, f, p, len); | |
6de9cd9a | 734 | else |
5e805e44 | 735 | write_l (dtp, f, p, len); |
6de9cd9a DN |
736 | |
737 | break; | |
738 | ||
739 | case FMT_D: | |
740 | if (n == 0) | |
741 | goto need_data; | |
5e805e44 | 742 | if (require_type (dtp, BT_REAL, type, f)) |
6de9cd9a DN |
743 | return; |
744 | ||
5e805e44 JJ |
745 | if (dtp->u.p.mode == READING) |
746 | read_f (dtp, f, p, len); | |
6de9cd9a | 747 | else |
5e805e44 | 748 | write_d (dtp, f, p, len); |
6de9cd9a DN |
749 | |
750 | break; | |
751 | ||
752 | case FMT_E: | |
753 | if (n == 0) | |
754 | goto need_data; | |
5e805e44 | 755 | if (require_type (dtp, BT_REAL, type, f)) |
6de9cd9a DN |
756 | return; |
757 | ||
5e805e44 JJ |
758 | if (dtp->u.p.mode == READING) |
759 | read_f (dtp, f, p, len); | |
6de9cd9a | 760 | else |
5e805e44 | 761 | write_e (dtp, f, p, len); |
6de9cd9a DN |
762 | break; |
763 | ||
764 | case FMT_EN: | |
765 | if (n == 0) | |
766 | goto need_data; | |
5e805e44 | 767 | if (require_type (dtp, BT_REAL, type, f)) |
6de9cd9a DN |
768 | return; |
769 | ||
5e805e44 JJ |
770 | if (dtp->u.p.mode == READING) |
771 | read_f (dtp, f, p, len); | |
6de9cd9a | 772 | else |
5e805e44 | 773 | write_en (dtp, f, p, len); |
6de9cd9a DN |
774 | |
775 | break; | |
776 | ||
777 | case FMT_ES: | |
778 | if (n == 0) | |
779 | goto need_data; | |
5e805e44 | 780 | if (require_type (dtp, BT_REAL, type, f)) |
6de9cd9a DN |
781 | return; |
782 | ||
5e805e44 JJ |
783 | if (dtp->u.p.mode == READING) |
784 | read_f (dtp, f, p, len); | |
6de9cd9a | 785 | else |
5e805e44 | 786 | write_es (dtp, f, p, len); |
6de9cd9a DN |
787 | |
788 | break; | |
789 | ||
790 | case FMT_F: | |
791 | if (n == 0) | |
792 | goto need_data; | |
5e805e44 | 793 | if (require_type (dtp, BT_REAL, type, f)) |
6de9cd9a DN |
794 | return; |
795 | ||
5e805e44 JJ |
796 | if (dtp->u.p.mode == READING) |
797 | read_f (dtp, f, p, len); | |
6de9cd9a | 798 | else |
5e805e44 | 799 | write_f (dtp, f, p, len); |
6de9cd9a DN |
800 | |
801 | break; | |
802 | ||
803 | case FMT_G: | |
804 | if (n == 0) | |
805 | goto need_data; | |
5e805e44 | 806 | if (dtp->u.p.mode == READING) |
6de9cd9a DN |
807 | switch (type) |
808 | { | |
809 | case BT_INTEGER: | |
5e805e44 | 810 | read_decimal (dtp, f, p, len); |
6de9cd9a DN |
811 | break; |
812 | case BT_LOGICAL: | |
5e805e44 | 813 | read_l (dtp, f, p, len); |
6de9cd9a DN |
814 | break; |
815 | case BT_CHARACTER: | |
5e805e44 | 816 | read_a (dtp, f, p, len); |
6de9cd9a DN |
817 | break; |
818 | case BT_REAL: | |
5e805e44 | 819 | read_f (dtp, f, p, len); |
6de9cd9a DN |
820 | break; |
821 | default: | |
822 | goto bad_type; | |
823 | } | |
824 | else | |
825 | switch (type) | |
826 | { | |
827 | case BT_INTEGER: | |
5e805e44 | 828 | write_i (dtp, f, p, len); |
6de9cd9a DN |
829 | break; |
830 | case BT_LOGICAL: | |
5e805e44 | 831 | write_l (dtp, f, p, len); |
6de9cd9a DN |
832 | break; |
833 | case BT_CHARACTER: | |
5e805e44 | 834 | write_a (dtp, f, p, len); |
6de9cd9a DN |
835 | break; |
836 | case BT_REAL: | |
5e805e44 | 837 | write_d (dtp, f, p, len); |
6de9cd9a DN |
838 | break; |
839 | default: | |
840 | bad_type: | |
5e805e44 JJ |
841 | internal_error (&dtp->common, |
842 | "formatted_transfer(): Bad type"); | |
6de9cd9a DN |
843 | } |
844 | ||
845 | break; | |
846 | ||
847 | case FMT_STRING: | |
be0cc7e2 | 848 | consume_data_flag = 0 ; |
5e805e44 | 849 | if (dtp->u.p.mode == READING) |
6de9cd9a | 850 | { |
5e805e44 | 851 | format_error (dtp, f, "Constant string in input format"); |
6de9cd9a DN |
852 | return; |
853 | } | |
5e805e44 | 854 | write_constant_string (dtp, f); |
6de9cd9a DN |
855 | break; |
856 | ||
be0cc7e2 | 857 | /* Format codes that don't transfer data. */ |
6de9cd9a DN |
858 | case FMT_X: |
859 | case FMT_TR: | |
be0cc7e2 PT |
860 | consume_data_flag = 0 ; |
861 | ||
5e805e44 JJ |
862 | pos = bytes_used + f->u.n + dtp->u.p.skips; |
863 | dtp->u.p.skips = f->u.n + dtp->u.p.skips; | |
864 | dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos; | |
be0cc7e2 | 865 | |
740f04ef JD |
866 | /* Writes occur just before the switch on f->format, above, so |
867 | that trailing blanks are suppressed, unless we are doing a | |
868 | non-advancing write in which case we want to output the blanks | |
869 | now. */ | |
5e805e44 JJ |
870 | if (dtp->u.p.mode == WRITING |
871 | && dtp->u.p.advance_status == ADVANCE_NO) | |
740f04ef | 872 | { |
5e805e44 JJ |
873 | write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); |
874 | dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
740f04ef | 875 | } |
5e805e44 JJ |
876 | if (dtp->u.p.mode == READING) |
877 | read_x (dtp, f->u.n); | |
6de9cd9a DN |
878 | |
879 | break; | |
880 | ||
be0cc7e2 PT |
881 | case FMT_TL: |
882 | case FMT_T: | |
883 | if (f->format == FMT_TL) | |
272c35bd JD |
884 | { |
885 | ||
886 | /* Handle the special case when no bytes have been used yet. | |
887 | Cannot go below zero. */ | |
888 | if (bytes_used == 0) | |
889 | { | |
890 | dtp->u.p.pending_spaces -= f->u.n; | |
891 | dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0 | |
892 | : dtp->u.p.pending_spaces; | |
893 | dtp->u.p.skips -= f->u.n; | |
894 | dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips; | |
895 | } | |
896 | ||
897 | pos = bytes_used - f->u.n; | |
898 | } | |
be0cc7e2 PT |
899 | else /* FMT_T */ |
900 | { | |
901 | consume_data_flag = 0; | |
902 | pos = f->u.n - 1; | |
903 | } | |
904 | ||
905 | /* Standard 10.6.1.1: excessive left tabbing is reset to the | |
906 | left tab limit. We do not check if the position has gone | |
907 | beyond the end of record because a subsequent tab could | |
908 | bring us back again. */ | |
909 | pos = pos < 0 ? 0 : pos; | |
910 | ||
5e805e44 JJ |
911 | dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used; |
912 | dtp->u.p.pending_spaces = dtp->u.p.pending_spaces | |
913 | + pos - dtp->u.p.max_pos; | |
be0cc7e2 | 914 | |
5e805e44 | 915 | if (dtp->u.p.skips == 0) |
be0cc7e2 PT |
916 | break; |
917 | ||
918 | /* Writes occur just before the switch on f->format, above, so that | |
919 | trailing blanks are suppressed. */ | |
5e805e44 | 920 | if (dtp->u.p.mode == READING) |
be0cc7e2 | 921 | { |
740f04ef | 922 | /* Adjust everything for end-of-record condition */ |
5e805e44 | 923 | if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) |
740f04ef | 924 | { |
8824fd4c FXC |
925 | if (dtp->u.p.sf_seen_eor == 2) |
926 | { | |
927 | /* The EOR was a CRLF (two bytes wide). */ | |
928 | dtp->u.p.current_unit->bytes_left -= 2; | |
929 | dtp->u.p.skips -= 2; | |
930 | } | |
931 | else | |
932 | { | |
933 | /* The EOR marker was only one byte wide. */ | |
934 | dtp->u.p.current_unit->bytes_left--; | |
935 | dtp->u.p.skips--; | |
936 | } | |
740f04ef | 937 | bytes_used = pos; |
5e805e44 | 938 | dtp->u.p.sf_seen_eor = 0; |
740f04ef | 939 | } |
5e805e44 | 940 | if (dtp->u.p.skips < 0) |
b6f571b7 | 941 | { |
5e805e44 JJ |
942 | move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips); |
943 | dtp->u.p.current_unit->bytes_left | |
944 | -= (gfc_offset) dtp->u.p.skips; | |
945 | dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
b6f571b7 | 946 | } |
740f04ef | 947 | else |
5e805e44 | 948 | read_x (dtp, dtp->u.p.skips); |
be0cc7e2 | 949 | } |
6de9cd9a DN |
950 | |
951 | break; | |
952 | ||
953 | case FMT_S: | |
be0cc7e2 | 954 | consume_data_flag = 0 ; |
5e805e44 | 955 | dtp->u.p.sign_status = SIGN_S; |
6de9cd9a DN |
956 | break; |
957 | ||
958 | case FMT_SS: | |
be0cc7e2 | 959 | consume_data_flag = 0 ; |
5e805e44 | 960 | dtp->u.p.sign_status = SIGN_SS; |
6de9cd9a DN |
961 | break; |
962 | ||
963 | case FMT_SP: | |
be0cc7e2 | 964 | consume_data_flag = 0 ; |
5e805e44 | 965 | dtp->u.p.sign_status = SIGN_SP; |
6de9cd9a DN |
966 | break; |
967 | ||
968 | case FMT_BN: | |
be0cc7e2 | 969 | consume_data_flag = 0 ; |
5e805e44 | 970 | dtp->u.p.blank_status = BLANK_NULL; |
6de9cd9a DN |
971 | break; |
972 | ||
973 | case FMT_BZ: | |
be0cc7e2 | 974 | consume_data_flag = 0 ; |
5e805e44 | 975 | dtp->u.p.blank_status = BLANK_ZERO; |
6de9cd9a DN |
976 | break; |
977 | ||
978 | case FMT_P: | |
be0cc7e2 | 979 | consume_data_flag = 0 ; |
5e805e44 | 980 | dtp->u.p.scale_factor = f->u.k; |
6de9cd9a DN |
981 | break; |
982 | ||
983 | case FMT_DOLLAR: | |
be0cc7e2 | 984 | consume_data_flag = 0 ; |
5e805e44 | 985 | dtp->u.p.seen_dollar = 1; |
6de9cd9a DN |
986 | break; |
987 | ||
988 | case FMT_SLASH: | |
be0cc7e2 | 989 | consume_data_flag = 0 ; |
5e805e44 JJ |
990 | dtp->u.p.skips = dtp->u.p.pending_spaces = 0; |
991 | next_record (dtp, 0); | |
6de9cd9a DN |
992 | break; |
993 | ||
994 | case FMT_COLON: | |
7fcb1804 TS |
995 | /* A colon descriptor causes us to exit this loop (in |
996 | particular preventing another / descriptor from being | |
997 | processed) unless there is another data item to be | |
998 | transferred. */ | |
be0cc7e2 | 999 | consume_data_flag = 0 ; |
6de9cd9a DN |
1000 | if (n == 0) |
1001 | return; | |
1002 | break; | |
1003 | ||
1004 | default: | |
5e805e44 | 1005 | internal_error (&dtp->common, "Bad format node"); |
6de9cd9a DN |
1006 | } |
1007 | ||
1008 | /* Free a buffer that we had to allocate during a sequential | |
7fcb1804 TS |
1009 | formatted read of a block that was larger than the static |
1010 | buffer. */ | |
6de9cd9a | 1011 | |
5e805e44 | 1012 | if (dtp->u.p.line_buffer != scratch) |
6de9cd9a | 1013 | { |
5e805e44 JJ |
1014 | free_mem (dtp->u.p.line_buffer); |
1015 | dtp->u.p.line_buffer = scratch; | |
6de9cd9a DN |
1016 | } |
1017 | ||
7fcb1804 | 1018 | /* Adjust the item count and data pointer. */ |
6de9cd9a DN |
1019 | |
1020 | if ((consume_data_flag > 0) && (n > 0)) | |
1021 | { | |
1022 | n--; | |
e5ef4b3b | 1023 | p = ((char *) p) + size; |
6de9cd9a | 1024 | } |
be0cc7e2 | 1025 | |
5e805e44 JJ |
1026 | if (dtp->u.p.mode == READING) |
1027 | dtp->u.p.skips = 0; | |
be0cc7e2 | 1028 | |
5e805e44 JJ |
1029 | pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); |
1030 | dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; | |
be0cc7e2 | 1031 | |
6de9cd9a DN |
1032 | } |
1033 | ||
1034 | return; | |
1035 | ||
f21edfd6 RH |
1036 | /* Come here when we need a data descriptor but don't have one. We |
1037 | push the current format node back onto the input, then return and | |
1038 | let the user program call us back with the data. */ | |
1039 | need_data: | |
5e805e44 | 1040 | unget_format (dtp, f); |
6de9cd9a DN |
1041 | } |
1042 | ||
18623fae | 1043 | static void |
5e805e44 JJ |
1044 | formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, |
1045 | size_t size, size_t nelems) | |
18623fae JB |
1046 | { |
1047 | size_t elem; | |
18623fae JB |
1048 | char *tmp; |
1049 | ||
1050 | tmp = (char *) p; | |
1051 | ||
18623fae JB |
1052 | /* Big loop over all the elements. */ |
1053 | for (elem = 0; elem < nelems; elem++) | |
1054 | { | |
5e805e44 JJ |
1055 | dtp->u.p.item_count++; |
1056 | formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size); | |
18623fae JB |
1057 | } |
1058 | } | |
1059 | ||
1060 | ||
6de9cd9a | 1061 | |
6de9cd9a | 1062 | /* Data transfer entry points. The type of the data entity is |
7fcb1804 TS |
1063 | implicit in the subroutine call. This prevents us from having to |
1064 | share a common enum with the compiler. */ | |
6de9cd9a DN |
1065 | |
1066 | void | |
5e805e44 | 1067 | transfer_integer (st_parameter_dt *dtp, void *p, int kind) |
6de9cd9a | 1068 | { |
5e805e44 | 1069 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a | 1070 | return; |
5e805e44 | 1071 | dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1); |
6de9cd9a DN |
1072 | } |
1073 | ||
1074 | ||
1075 | void | |
5e805e44 | 1076 | transfer_real (st_parameter_dt *dtp, void *p, int kind) |
6de9cd9a | 1077 | { |
e5ef4b3b | 1078 | size_t size; |
5e805e44 | 1079 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a | 1080 | return; |
e5ef4b3b | 1081 | size = size_from_real_kind (kind); |
5e805e44 | 1082 | dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1); |
6de9cd9a DN |
1083 | } |
1084 | ||
1085 | ||
1086 | void | |
5e805e44 | 1087 | transfer_logical (st_parameter_dt *dtp, void *p, int kind) |
6de9cd9a | 1088 | { |
5e805e44 | 1089 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a | 1090 | return; |
5e805e44 | 1091 | dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1); |
6de9cd9a DN |
1092 | } |
1093 | ||
1094 | ||
1095 | void | |
5e805e44 | 1096 | transfer_character (st_parameter_dt *dtp, void *p, int len) |
6de9cd9a | 1097 | { |
5e805e44 | 1098 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a | 1099 | return; |
e5ef4b3b JB |
1100 | /* Currently we support only 1 byte chars, and the library is a bit |
1101 | confused of character kind vs. length, so we kludge it by setting | |
1102 | kind = length. */ | |
5e805e44 | 1103 | dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1); |
6de9cd9a DN |
1104 | } |
1105 | ||
1106 | ||
1107 | void | |
5e805e44 | 1108 | transfer_complex (st_parameter_dt *dtp, void *p, int kind) |
6de9cd9a | 1109 | { |
e5ef4b3b | 1110 | size_t size; |
5e805e44 | 1111 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a | 1112 | return; |
e5ef4b3b | 1113 | size = size_from_complex_kind (kind); |
5e805e44 | 1114 | dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1); |
18623fae JB |
1115 | } |
1116 | ||
1117 | ||
1118 | void | |
5e805e44 JJ |
1119 | transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, |
1120 | gfc_charlen_type charlen) | |
18623fae JB |
1121 | { |
1122 | index_type count[GFC_MAX_DIMENSIONS]; | |
1123 | index_type extent[GFC_MAX_DIMENSIONS]; | |
1124 | index_type stride[GFC_MAX_DIMENSIONS]; | |
e5ef4b3b | 1125 | index_type stride0, rank, size, type, n; |
18623fae JB |
1126 | size_t tsize; |
1127 | char *data; | |
1128 | bt iotype; | |
1129 | ||
5e805e44 | 1130 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
18623fae JB |
1131 | return; |
1132 | ||
1133 | type = GFC_DESCRIPTOR_TYPE (desc); | |
1134 | size = GFC_DESCRIPTOR_SIZE (desc); | |
18623fae JB |
1135 | |
1136 | /* FIXME: What a kludge: Array descriptors and the IO library use | |
1137 | different enums for types. */ | |
1138 | switch (type) | |
1139 | { | |
1140 | case GFC_DTYPE_UNKNOWN: | |
1141 | iotype = BT_NULL; /* Is this correct? */ | |
1142 | break; | |
1143 | case GFC_DTYPE_INTEGER: | |
1144 | iotype = BT_INTEGER; | |
1145 | break; | |
1146 | case GFC_DTYPE_LOGICAL: | |
1147 | iotype = BT_LOGICAL; | |
1148 | break; | |
1149 | case GFC_DTYPE_REAL: | |
1150 | iotype = BT_REAL; | |
1151 | break; | |
1152 | case GFC_DTYPE_COMPLEX: | |
1153 | iotype = BT_COMPLEX; | |
18623fae JB |
1154 | break; |
1155 | case GFC_DTYPE_CHARACTER: | |
1156 | iotype = BT_CHARACTER; | |
1157 | /* FIXME: Currently dtype contains the charlen, which is | |
1158 | clobbered if charlen > 2**24. That's why we use a separate | |
1159 | argument for the charlen. However, if we want to support | |
1160 | non-8-bit charsets we need to fix dtype to contain | |
1161 | sizeof(chartype) and fix the code below. */ | |
1162 | size = charlen; | |
1163 | kind = charlen; | |
1164 | break; | |
1165 | case GFC_DTYPE_DERIVED: | |
5e805e44 JJ |
1166 | internal_error (&dtp->common, |
1167 | "Derived type I/O should have been handled via the frontend."); | |
18623fae JB |
1168 | break; |
1169 | default: | |
5e805e44 | 1170 | internal_error (&dtp->common, "transfer_array(): Bad type"); |
18623fae JB |
1171 | } |
1172 | ||
1173 | if (desc->dim[0].stride == 0) | |
1174 | desc->dim[0].stride = 1; | |
1175 | ||
1176 | rank = GFC_DESCRIPTOR_RANK (desc); | |
1177 | for (n = 0; n < rank; n++) | |
1178 | { | |
1179 | count[n] = 0; | |
1180 | stride[n] = desc->dim[n].stride; | |
1181 | extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound; | |
1182 | ||
1183 | /* If the extent of even one dimension is zero, then the entire | |
1184 | array section contains zero elements, so we return. */ | |
1185 | if (extent[n] == 0) | |
1186 | return; | |
1187 | } | |
1188 | ||
1189 | stride0 = stride[0]; | |
1190 | ||
1191 | /* If the innermost dimension has stride 1, we can do the transfer | |
1192 | in contiguous chunks. */ | |
1193 | if (stride0 == 1) | |
1194 | tsize = extent[0]; | |
1195 | else | |
1196 | tsize = 1; | |
1197 | ||
1198 | data = GFC_DESCRIPTOR_DATA (desc); | |
1199 | ||
1200 | while (data) | |
1201 | { | |
5e805e44 | 1202 | dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize); |
18623fae JB |
1203 | data += stride0 * size * tsize; |
1204 | count[0] += tsize; | |
1205 | n = 0; | |
1206 | while (count[n] == extent[n]) | |
1207 | { | |
1208 | count[n] = 0; | |
1209 | data -= stride[n] * extent[n] * size; | |
1210 | n++; | |
1211 | if (n == rank) | |
1212 | { | |
1213 | data = NULL; | |
1214 | break; | |
1215 | } | |
1216 | else | |
1217 | { | |
1218 | count[n]++; | |
1219 | data += stride[n] * size; | |
1220 | } | |
1221 | } | |
1222 | } | |
6de9cd9a DN |
1223 | } |
1224 | ||
1225 | ||
7fcb1804 | 1226 | /* Preposition a sequential unformatted file while reading. */ |
6de9cd9a DN |
1227 | |
1228 | static void | |
5e805e44 | 1229 | us_read (st_parameter_dt *dtp) |
6de9cd9a | 1230 | { |
08656747 | 1231 | char *p; |
6de9cd9a | 1232 | int n; |
08656747 | 1233 | gfc_offset i; |
6de9cd9a | 1234 | |
7b7034ea JD |
1235 | if (dtp->u.p.current_unit->endfile == AT_ENDFILE) |
1236 | return; | |
1237 | ||
81f4be3c | 1238 | n = sizeof (gfc_offset); |
5e805e44 | 1239 | p = salloc_r (dtp->u.p.current_unit->s, &n); |
6de9cd9a | 1240 | |
f53d3f93 | 1241 | if (n == 0) |
7b7034ea JD |
1242 | { |
1243 | dtp->u.p.current_unit->endfile = AT_ENDFILE; | |
1244 | return; /* end of file */ | |
1245 | } | |
f53d3f93 | 1246 | |
81f4be3c | 1247 | if (p == NULL || n != sizeof (gfc_offset)) |
6de9cd9a | 1248 | { |
5e805e44 | 1249 | generate_error (&dtp->common, ERROR_BAD_US, NULL); |
6de9cd9a DN |
1250 | return; |
1251 | } | |
1252 | ||
181c9f4a TK |
1253 | /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ |
1254 | if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE) | |
1255 | memcpy (&i, p, sizeof (gfc_offset)); | |
1256 | else | |
1257 | reverse_memcpy (&i, p, sizeof (gfc_offset)); | |
1258 | ||
5e805e44 | 1259 | dtp->u.p.current_unit->bytes_left = i; |
6de9cd9a DN |
1260 | } |
1261 | ||
1262 | ||
7fcb1804 TS |
1263 | /* Preposition a sequential unformatted file while writing. This |
1264 | amount to writing a bogus length that will be filled in later. */ | |
6de9cd9a DN |
1265 | |
1266 | static void | |
5e805e44 | 1267 | us_write (st_parameter_dt *dtp) |
6de9cd9a | 1268 | { |
82b8244c JB |
1269 | size_t nbytes; |
1270 | gfc_offset dummy; | |
6de9cd9a | 1271 | |
82b8244c JB |
1272 | dummy = 0; |
1273 | nbytes = sizeof (gfc_offset); | |
6de9cd9a | 1274 | |
82b8244c | 1275 | if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0) |
5e805e44 | 1276 | generate_error (&dtp->common, ERROR_OS, NULL); |
6de9cd9a | 1277 | |
82b8244c JB |
1278 | /* For sequential unformatted, we write until we have more bytes |
1279 | than can fit in the record markers. If disk space runs out first, | |
1280 | it will error on the write. */ | |
5e805e44 | 1281 | dtp->u.p.current_unit->recl = max_offset; |
bf1df0a0 | 1282 | |
5e805e44 | 1283 | dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; |
6de9cd9a DN |
1284 | } |
1285 | ||
1286 | ||
7fcb1804 TS |
1287 | /* Position to the next record prior to transfer. We are assumed to |
1288 | be before the next record. We also calculate the bytes in the next | |
1289 | record. */ | |
6de9cd9a DN |
1290 | |
1291 | static void | |
5e805e44 | 1292 | pre_position (st_parameter_dt *dtp) |
6de9cd9a | 1293 | { |
5e805e44 | 1294 | if (dtp->u.p.current_unit->current_record) |
7fcb1804 | 1295 | return; /* Already positioned. */ |
6de9cd9a | 1296 | |
5e805e44 | 1297 | switch (current_mode (dtp)) |
6de9cd9a DN |
1298 | { |
1299 | case UNFORMATTED_SEQUENTIAL: | |
5e805e44 JJ |
1300 | if (dtp->u.p.mode == READING) |
1301 | us_read (dtp); | |
6de9cd9a | 1302 | else |
5e805e44 | 1303 | us_write (dtp); |
6de9cd9a DN |
1304 | |
1305 | break; | |
1306 | ||
1307 | case FORMATTED_SEQUENTIAL: | |
1308 | case FORMATTED_DIRECT: | |
1309 | case UNFORMATTED_DIRECT: | |
5e805e44 | 1310 | dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; |
6de9cd9a DN |
1311 | break; |
1312 | } | |
1313 | ||
5e805e44 | 1314 | dtp->u.p.current_unit->current_record = 1; |
6de9cd9a DN |
1315 | } |
1316 | ||
1317 | ||
7fcb1804 TS |
1318 | /* Initialize things for a data transfer. This code is common for |
1319 | both reading and writing. */ | |
6de9cd9a DN |
1320 | |
1321 | static void | |
5e805e44 | 1322 | data_transfer_init (st_parameter_dt *dtp, int read_flag) |
6de9cd9a | 1323 | { |
7fcb1804 | 1324 | unit_flags u_flags; /* Used for creating a unit if needed. */ |
5e805e44 JJ |
1325 | GFC_INTEGER_4 cf = dtp->common.flags; |
1326 | namelist_info *ionml; | |
6de9cd9a | 1327 | |
5e805e44 JJ |
1328 | ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL; |
1329 | memset (&dtp->u.p, 0, sizeof (dtp->u.p)); | |
1330 | dtp->u.p.ionml = ionml; | |
1331 | dtp->u.p.mode = read_flag ? READING : WRITING; | |
6de9cd9a | 1332 | |
5e805e44 JJ |
1333 | if ((cf & IOPARM_DT_HAS_SIZE) != 0) |
1334 | *dtp->size = 0; /* Initialize the count. */ | |
6de9cd9a | 1335 | |
5e805e44 JJ |
1336 | dtp->u.p.current_unit = get_unit (dtp, 1); |
1337 | if (dtp->u.p.current_unit->s == NULL) | |
7fcb1804 | 1338 | { /* Open the unit with some default flags. */ |
5e805e44 JJ |
1339 | st_parameter_open opp; |
1340 | if (dtp->common.unit < 0) | |
14fd645e | 1341 | { |
5e805e44 JJ |
1342 | close_unit (dtp->u.p.current_unit); |
1343 | dtp->u.p.current_unit = NULL; | |
1344 | generate_error (&dtp->common, ERROR_BAD_OPTION, | |
1345 | "Bad unit number in OPEN statement"); | |
14fd645e FXC |
1346 | return; |
1347 | } | |
6de9cd9a DN |
1348 | memset (&u_flags, '\0', sizeof (u_flags)); |
1349 | u_flags.access = ACCESS_SEQUENTIAL; | |
1350 | u_flags.action = ACTION_READWRITE; | |
cc0de35e | 1351 | |
7fcb1804 | 1352 | /* Is it unformatted? */ |
cc0de35e FXC |
1353 | if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT |
1354 | | IOPARM_DT_IONML_SET))) | |
bf1df0a0 BD |
1355 | u_flags.form = FORM_UNFORMATTED; |
1356 | else | |
1357 | u_flags.form = FORM_UNSPECIFIED; | |
cc0de35e | 1358 | |
6de9cd9a DN |
1359 | u_flags.delim = DELIM_UNSPECIFIED; |
1360 | u_flags.blank = BLANK_UNSPECIFIED; | |
1361 | u_flags.pad = PAD_UNSPECIFIED; | |
1362 | u_flags.status = STATUS_UNKNOWN; | |
5e805e44 JJ |
1363 | opp.common = dtp->common; |
1364 | opp.common.flags &= IOPARM_COMMON_MASK; | |
1365 | dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags); | |
1366 | dtp->common.flags &= ~IOPARM_COMMON_MASK; | |
1367 | dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK); | |
1368 | if (dtp->u.p.current_unit == NULL) | |
1369 | return; | |
6de9cd9a DN |
1370 | } |
1371 | ||
7fcb1804 | 1372 | /* Check the action. */ |
6de9cd9a | 1373 | |
5e805e44 JJ |
1374 | if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) |
1375 | generate_error (&dtp->common, ERROR_BAD_ACTION, | |
6de9cd9a DN |
1376 | "Cannot read from file opened for WRITE"); |
1377 | ||
5e805e44 JJ |
1378 | if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ) |
1379 | generate_error (&dtp->common, ERROR_BAD_ACTION, | |
1380 | "Cannot write to file opened for READ"); | |
6de9cd9a | 1381 | |
5e805e44 | 1382 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a DN |
1383 | return; |
1384 | ||
5e805e44 JJ |
1385 | dtp->u.p.first_item = 1; |
1386 | ||
7fcb1804 | 1387 | /* Check the format. */ |
6de9cd9a | 1388 | |
5e805e44 JJ |
1389 | if ((cf & IOPARM_DT_HAS_FORMAT) != 0) |
1390 | parse_format (dtp); | |
6de9cd9a | 1391 | |
5e805e44 | 1392 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
6de9cd9a DN |
1393 | return; |
1394 | ||
5e805e44 JJ |
1395 | if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED |
1396 | && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) | |
1397 | != 0) | |
1398 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1399 | "Format present for UNFORMATTED data transfer"); |
1400 | ||
5e805e44 | 1401 | if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL) |
6de9cd9a | 1402 | { |
5e805e44 JJ |
1403 | if ((cf & IOPARM_DT_HAS_FORMAT) != 0) |
1404 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
be0cc7e2 | 1405 | "A format cannot be specified with a namelist"); |
6de9cd9a | 1406 | } |
5e805e44 JJ |
1407 | else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && |
1408 | !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))) | |
1409 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
be0cc7e2 | 1410 | "Missing format for FORMATTED data transfer"); |
6de9cd9a DN |
1411 | |
1412 | ||
5e805e44 JJ |
1413 | if (is_internal_unit (dtp) |
1414 | && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) | |
1415 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1416 | "Internal file cannot be accessed by UNFORMATTED data transfer"); |
1417 | ||
7fcb1804 | 1418 | /* Check the record number. */ |
6de9cd9a | 1419 | |
5e805e44 JJ |
1420 | if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT |
1421 | && (cf & IOPARM_DT_HAS_REC) == 0) | |
6de9cd9a | 1422 | { |
5e805e44 | 1423 | generate_error (&dtp->common, ERROR_MISSING_OPTION, |
6de9cd9a DN |
1424 | "Direct access data transfer requires record number"); |
1425 | return; | |
1426 | } | |
1427 | ||
5e805e44 JJ |
1428 | if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL |
1429 | && (cf & IOPARM_DT_HAS_REC) != 0) | |
6de9cd9a | 1430 | { |
5e805e44 | 1431 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, |
6de9cd9a DN |
1432 | "Record number not allowed for sequential access data transfer"); |
1433 | return; | |
1434 | } | |
1435 | ||
7fcb1804 | 1436 | /* Process the ADVANCE option. */ |
6de9cd9a | 1437 | |
5e805e44 JJ |
1438 | dtp->u.p.advance_status |
1439 | = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED : | |
1440 | find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt, | |
1441 | "Bad ADVANCE parameter in data transfer statement"); | |
6de9cd9a | 1442 | |
5e805e44 | 1443 | if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED) |
6de9cd9a | 1444 | { |
5e805e44 JJ |
1445 | if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) |
1446 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1447 | "ADVANCE specification conflicts with sequential access"); |
1448 | ||
5e805e44 JJ |
1449 | if (is_internal_unit (dtp)) |
1450 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1451 | "ADVANCE specification conflicts with internal file"); |
1452 | ||
5e805e44 JJ |
1453 | if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) |
1454 | != IOPARM_DT_HAS_FORMAT) | |
1455 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1456 | "ADVANCE specification requires an explicit format"); |
1457 | } | |
1458 | ||
1459 | if (read_flag) | |
1460 | { | |
5e805e44 JJ |
1461 | if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO) |
1462 | generate_error (&dtp->common, ERROR_MISSING_OPTION, | |
6de9cd9a DN |
1463 | "EOR specification requires an ADVANCE specification of NO"); |
1464 | ||
5e805e44 JJ |
1465 | if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO) |
1466 | generate_error (&dtp->common, ERROR_MISSING_OPTION, | |
6de9cd9a DN |
1467 | "SIZE specification requires an ADVANCE specification of NO"); |
1468 | ||
1469 | } | |
1470 | else | |
7fcb1804 | 1471 | { /* Write constraints. */ |
5e805e44 JJ |
1472 | if ((cf & IOPARM_END) != 0) |
1473 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1474 | "END specification cannot appear in a write statement"); |
1475 | ||
5e805e44 JJ |
1476 | if ((cf & IOPARM_EOR) != 0) |
1477 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1478 | "EOR specification cannot appear in a write statement"); |
1479 | ||
5e805e44 JJ |
1480 | if ((cf & IOPARM_DT_HAS_SIZE) != 0) |
1481 | generate_error (&dtp->common, ERROR_OPTION_CONFLICT, | |
6de9cd9a DN |
1482 | "SIZE specification cannot appear in a write statement"); |
1483 | } | |
1484 | ||
5e805e44 JJ |
1485 | if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED) |
1486 | dtp->u.p.advance_status = ADVANCE_YES; | |
1487 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
6de9cd9a DN |
1488 | return; |
1489 | ||
7fcb1804 | 1490 | /* Sanity checks on the record number. */ |
6de9cd9a | 1491 | |
5e805e44 | 1492 | if ((cf & IOPARM_DT_HAS_REC) != 0) |
6de9cd9a | 1493 | { |
5e805e44 | 1494 | if (dtp->rec <= 0) |
6de9cd9a | 1495 | { |
5e805e44 JJ |
1496 | generate_error (&dtp->common, ERROR_BAD_OPTION, |
1497 | "Record number must be positive"); | |
6de9cd9a DN |
1498 | return; |
1499 | } | |
1500 | ||
5e805e44 | 1501 | if (dtp->rec >= dtp->u.p.current_unit->maxrec) |
6de9cd9a | 1502 | { |
5e805e44 JJ |
1503 | generate_error (&dtp->common, ERROR_BAD_OPTION, |
1504 | "Record number too large"); | |
6de9cd9a DN |
1505 | return; |
1506 | } | |
1507 | ||
55948b69 BD |
1508 | /* Check to see if we might be reading what we wrote before */ |
1509 | ||
5e805e44 JJ |
1510 | if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode == WRITING) |
1511 | flush(dtp->u.p.current_unit->s); | |
6de9cd9a | 1512 | |
0ef63495 TK |
1513 | /* Check whether the record exists to be read. Only |
1514 | a partial record needs to exist. */ | |
1515 | ||
5e805e44 JJ |
1516 | if (dtp->u.p.mode == READING && (dtp->rec -1) |
1517 | * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s)) | |
0ef63495 | 1518 | { |
5e805e44 JJ |
1519 | generate_error (&dtp->common, ERROR_BAD_OPTION, |
1520 | "Non-existing record number"); | |
0ef63495 TK |
1521 | return; |
1522 | } | |
1523 | ||
55948b69 | 1524 | /* Position the file. */ |
5e805e44 JJ |
1525 | if (sseek (dtp->u.p.current_unit->s, |
1526 | (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE) | |
0ef63495 | 1527 | { |
5e805e44 | 1528 | generate_error (&dtp->common, ERROR_OS, NULL); |
0ef63495 TK |
1529 | return; |
1530 | } | |
6de9cd9a DN |
1531 | } |
1532 | ||
420aa7b8 | 1533 | /* Overwriting an existing sequential file ? |
48248fa7 | 1534 | it is always safe to truncate the file on the first write */ |
5e805e44 JJ |
1535 | if (dtp->u.p.mode == WRITING |
1536 | && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL | |
1537 | && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s)) | |
1538 | struncate(dtp->u.p.current_unit->s); | |
48248fa7 | 1539 | |
159840cb | 1540 | /* Bugware for badly written mixed C-Fortran I/O. */ |
5e805e44 | 1541 | flush_if_preconnected(dtp->u.p.current_unit->s); |
159840cb | 1542 | |
5e805e44 | 1543 | dtp->u.p.current_unit->mode = dtp->u.p.mode; |
55948b69 | 1544 | |
7fcb1804 | 1545 | /* Set the initial value of flags. */ |
6de9cd9a | 1546 | |
5e805e44 JJ |
1547 | dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank; |
1548 | dtp->u.p.sign_status = SIGN_S; | |
6de9cd9a | 1549 | |
5e805e44 | 1550 | pre_position (dtp); |
6de9cd9a | 1551 | |
7fcb1804 | 1552 | /* Set up the subroutine that will handle the transfers. */ |
6de9cd9a DN |
1553 | |
1554 | if (read_flag) | |
1555 | { | |
5e805e44 JJ |
1556 | if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) |
1557 | dtp->u.p.transfer = unformatted_read; | |
6de9cd9a DN |
1558 | else |
1559 | { | |
5e805e44 JJ |
1560 | if ((cf & IOPARM_DT_LIST_FORMAT) != 0) |
1561 | dtp->u.p.transfer = list_formatted_read; | |
6de9cd9a | 1562 | else |
5e805e44 | 1563 | dtp->u.p.transfer = formatted_transfer; |
6de9cd9a DN |
1564 | } |
1565 | } | |
1566 | else | |
1567 | { | |
5e805e44 JJ |
1568 | if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) |
1569 | dtp->u.p.transfer = unformatted_write; | |
6de9cd9a DN |
1570 | else |
1571 | { | |
5e805e44 JJ |
1572 | if ((cf & IOPARM_DT_LIST_FORMAT) != 0) |
1573 | dtp->u.p.transfer = list_formatted_write; | |
6de9cd9a | 1574 | else |
5e805e44 | 1575 | dtp->u.p.transfer = formatted_transfer; |
6de9cd9a DN |
1576 | } |
1577 | } | |
1578 | ||
7fcb1804 | 1579 | /* Make sure that we don't do a read after a nonadvancing write. */ |
6de9cd9a DN |
1580 | |
1581 | if (read_flag) | |
1582 | { | |
5e805e44 | 1583 | if (dtp->u.p.current_unit->read_bad) |
6de9cd9a | 1584 | { |
5e805e44 | 1585 | generate_error (&dtp->common, ERROR_BAD_OPTION, |
6de9cd9a DN |
1586 | "Cannot READ after a nonadvancing WRITE"); |
1587 | return; | |
1588 | } | |
1589 | } | |
1590 | else | |
1591 | { | |
5e805e44 JJ |
1592 | if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar) |
1593 | dtp->u.p.current_unit->read_bad = 1; | |
6de9cd9a DN |
1594 | } |
1595 | ||
7fcb1804 | 1596 | /* Start the data transfer if we are doing a formatted transfer. */ |
5e805e44 JJ |
1597 | if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED |
1598 | && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0) | |
1599 | && dtp->u.p.ionml == NULL) | |
1600 | formatted_transfer (dtp, 0, NULL, 0, 0, 1); | |
6de9cd9a DN |
1601 | } |
1602 | ||
965eec16 JD |
1603 | /* Initialize an array_loop_spec given the array descriptor. The function |
1604 | returns the index of the last element of the array. */ | |
1605 | ||
1606 | gfc_offset | |
1607 | init_loop_spec (gfc_array_char *desc, array_loop_spec *ls) | |
1608 | { | |
1609 | int rank = GFC_DESCRIPTOR_RANK(desc); | |
1610 | int i; | |
1611 | gfc_offset index; | |
1612 | ||
1613 | index = 1; | |
1614 | for (i=0; i<rank; i++) | |
1615 | { | |
1616 | ls[i].idx = 1; | |
1617 | ls[i].start = desc->dim[i].lbound; | |
1618 | ls[i].end = desc->dim[i].ubound; | |
1619 | ls[i].step = desc->dim[i].stride; | |
1620 | ||
1621 | index += (desc->dim[i].ubound - desc->dim[i].lbound) | |
1622 | * desc->dim[i].stride; | |
1623 | } | |
1624 | return index; | |
1625 | } | |
1626 | ||
1627 | /* Determine the index to the next record in an internal unit array by | |
1628 | by incrementing through the array_loop_spec. TODO: Implement handling | |
1629 | negative strides. */ | |
1630 | ||
1631 | gfc_offset | |
5e805e44 | 1632 | next_array_record (st_parameter_dt *dtp, array_loop_spec *ls) |
965eec16 JD |
1633 | { |
1634 | int i, carry; | |
1635 | gfc_offset index; | |
1636 | ||
1637 | carry = 1; | |
1638 | index = 0; | |
1639 | ||
5e805e44 | 1640 | for (i = 0; i < dtp->u.p.current_unit->rank; i++) |
965eec16 JD |
1641 | { |
1642 | if (carry) | |
1643 | { | |
1644 | ls[i].idx++; | |
1645 | if (ls[i].idx > ls[i].end) | |
1646 | { | |
1647 | ls[i].idx = ls[i].start; | |
1648 | carry = 1; | |
1649 | } | |
1650 | else | |
1651 | carry = 0; | |
1652 | } | |
1653 | index = index + (ls[i].idx - 1) * ls[i].step; | |
1654 | } | |
1655 | return index; | |
1656 | } | |
6de9cd9a | 1657 | |
7fcb1804 TS |
1658 | /* Space to the next record for read mode. If the file is not |
1659 | seekable, we read MAX_READ chunks until we get to the right | |
1660 | position. */ | |
6de9cd9a DN |
1661 | |
1662 | #define MAX_READ 4096 | |
1663 | ||
1664 | static void | |
5e805e44 | 1665 | next_record_r (st_parameter_dt *dtp) |
6de9cd9a | 1666 | { |
965eec16 JD |
1667 | gfc_offset new, record; |
1668 | int bytes_left, rlength, length; | |
6de9cd9a DN |
1669 | char *p; |
1670 | ||
5e805e44 | 1671 | switch (current_mode (dtp)) |
6de9cd9a DN |
1672 | { |
1673 | case UNFORMATTED_SEQUENTIAL: | |
6de9cd9a | 1674 | |
9696b225 JD |
1675 | /* Skip over tail */ |
1676 | dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset); | |
1677 | ||
7fcb1804 | 1678 | /* Fall through... */ |
6de9cd9a DN |
1679 | |
1680 | case FORMATTED_DIRECT: | |
1681 | case UNFORMATTED_DIRECT: | |
5e805e44 | 1682 | if (dtp->u.p.current_unit->bytes_left == 0) |
6de9cd9a DN |
1683 | break; |
1684 | ||
5e805e44 | 1685 | if (is_seekable (dtp->u.p.current_unit->s)) |
6de9cd9a | 1686 | { |
9696b225 JD |
1687 | new = file_position (dtp->u.p.current_unit->s) |
1688 | + dtp->u.p.current_unit->bytes_left; | |
6de9cd9a | 1689 | |
420aa7b8 | 1690 | /* Direct access files do not generate END conditions, |
7fcb1804 | 1691 | only I/O errors. */ |
5e805e44 JJ |
1692 | if (sseek (dtp->u.p.current_unit->s, new) == FAILURE) |
1693 | generate_error (&dtp->common, ERROR_OS, NULL); | |
6de9cd9a DN |
1694 | |
1695 | } | |
1696 | else | |
7fcb1804 | 1697 | { /* Seek by reading data. */ |
5e805e44 | 1698 | while (dtp->u.p.current_unit->bytes_left > 0) |
6de9cd9a | 1699 | { |
5e805e44 JJ |
1700 | rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ? |
1701 | MAX_READ : dtp->u.p.current_unit->bytes_left; | |
6de9cd9a | 1702 | |
5e805e44 | 1703 | p = salloc_r (dtp->u.p.current_unit->s, &rlength); |
6de9cd9a DN |
1704 | if (p == NULL) |
1705 | { | |
5e805e44 | 1706 | generate_error (&dtp->common, ERROR_OS, NULL); |
6de9cd9a DN |
1707 | break; |
1708 | } | |
1709 | ||
5e805e44 | 1710 | dtp->u.p.current_unit->bytes_left -= length; |
6de9cd9a DN |
1711 | } |
1712 | } | |
6de9cd9a DN |
1713 | break; |
1714 | ||
1715 | case FORMATTED_SEQUENTIAL: | |
1716 | length = 1; | |
a7e8d7db | 1717 | /* sf_read has already terminated input because of an '\n' */ |
5e805e44 | 1718 | if (dtp->u.p.sf_seen_eor) |
59afe4b4 | 1719 | { |
5e805e44 | 1720 | dtp->u.p.sf_seen_eor = 0; |
59afe4b4 TK |
1721 | break; |
1722 | } | |
6de9cd9a | 1723 | |
5e805e44 | 1724 | if (is_internal_unit (dtp)) |
59154ed2 | 1725 | { |
5e805e44 JJ |
1726 | if (is_array_io (dtp)) |
1727 | { | |
1728 | record = next_array_record (dtp, dtp->u.p.current_unit->ls); | |
1729 | ||
1730 | /* Now seek to this record. */ | |
1731 | record = record * dtp->u.p.current_unit->recl; | |
1732 | if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) | |
1733 | { | |
844234fb | 1734 | generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); |
5e805e44 JJ |
1735 | break; |
1736 | } | |
1737 | dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
1738 | } | |
1739 | else | |
1740 | { | |
1741 | bytes_left = (int) dtp->u.p.current_unit->bytes_left; | |
1742 | p = salloc_r (dtp->u.p.current_unit->s, &bytes_left); | |
1743 | if (p != NULL) | |
1744 | dtp->u.p.current_unit->bytes_left | |
1745 | = dtp->u.p.current_unit->recl; | |
1746 | } | |
1747 | break; | |
59154ed2 JD |
1748 | } |
1749 | else do | |
be0cc7e2 | 1750 | { |
5e805e44 | 1751 | p = salloc_r (dtp->u.p.current_unit->s, &length); |
be0cc7e2 | 1752 | |
be0cc7e2 PT |
1753 | if (p == NULL) |
1754 | { | |
5e805e44 | 1755 | generate_error (&dtp->common, ERROR_OS, NULL); |
be0cc7e2 PT |
1756 | break; |
1757 | } | |
1758 | ||
1759 | if (length == 0) | |
1760 | { | |
5e805e44 | 1761 | dtp->u.p.current_unit->endfile = AT_ENDFILE; |
be0cc7e2 PT |
1762 | break; |
1763 | } | |
1764 | } | |
6de9cd9a DN |
1765 | while (*p != '\n'); |
1766 | ||
1767 | break; | |
1768 | } | |
1769 | ||
5e805e44 JJ |
1770 | if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) |
1771 | test_endfile (dtp->u.p.current_unit); | |
6de9cd9a DN |
1772 | } |
1773 | ||
1774 | ||
82b8244c JB |
1775 | /* Small utility function to write a record marker, taking care of |
1776 | byte swapping. */ | |
1777 | ||
1778 | inline static int | |
1779 | write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) | |
1780 | { | |
1781 | size_t len = sizeof (gfc_offset); | |
1782 | /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ | |
1783 | if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE) | |
1784 | return swrite (dtp->u.p.current_unit->s, &buf, &len); | |
1785 | else { | |
1786 | gfc_offset p; | |
1787 | reverse_memcpy (&p, &buf, sizeof (gfc_offset)); | |
1788 | return swrite (dtp->u.p.current_unit->s, &p, &len); | |
1789 | } | |
1790 | } | |
1791 | ||
1792 | ||
7fcb1804 | 1793 | /* Position to the next record in write mode. */ |
6de9cd9a DN |
1794 | |
1795 | static void | |
494ef4c2 | 1796 | next_record_w (st_parameter_dt *dtp, int done) |
6de9cd9a | 1797 | { |
494ef4c2 JD |
1798 | gfc_offset c, m, record, max_pos; |
1799 | int length; | |
6de9cd9a DN |
1800 | char *p; |
1801 | ||
94e2b58a | 1802 | /* Zero counters for X- and T-editing. */ |
494ef4c2 | 1803 | max_pos = dtp->u.p.max_pos; |
5e805e44 | 1804 | dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0; |
94e2b58a | 1805 | |
5e805e44 | 1806 | switch (current_mode (dtp)) |
6de9cd9a DN |
1807 | { |
1808 | case FORMATTED_DIRECT: | |
5e805e44 | 1809 | if (dtp->u.p.current_unit->bytes_left == 0) |
6de9cd9a DN |
1810 | break; |
1811 | ||
82b8244c JB |
1812 | if (sset (dtp->u.p.current_unit->s, ' ', |
1813 | dtp->u.p.current_unit->bytes_left) == FAILURE) | |
6de9cd9a DN |
1814 | goto io_error; |
1815 | ||
0fa1b65c | 1816 | break; |
6de9cd9a | 1817 | |
0fa1b65c | 1818 | case UNFORMATTED_DIRECT: |
5e805e44 | 1819 | if (sfree (dtp->u.p.current_unit->s) == FAILURE) |
be0cc7e2 | 1820 | goto io_error; |
6de9cd9a DN |
1821 | break; |
1822 | ||
1823 | case UNFORMATTED_SEQUENTIAL: | |
5e805e44 JJ |
1824 | /* Bytes written. */ |
1825 | m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left; | |
1826 | c = file_position (dtp->u.p.current_unit->s); | |
6de9cd9a | 1827 | |
7fcb1804 | 1828 | /* Write the length tail. */ |
6de9cd9a | 1829 | |
82b8244c | 1830 | if (write_us_marker (dtp, m) != 0) |
6de9cd9a DN |
1831 | goto io_error; |
1832 | ||
7fcb1804 TS |
1833 | /* Seek to the head and overwrite the bogus length with the real |
1834 | length. */ | |
6de9cd9a | 1835 | |
82b8244c JB |
1836 | if (sseek (dtp->u.p.current_unit->s, c - m - sizeof (gfc_offset)) |
1837 | == FAILURE) | |
1838 | goto io_error; | |
6de9cd9a | 1839 | |
82b8244c | 1840 | if (write_us_marker (dtp, m) != 0) |
6de9cd9a DN |
1841 | goto io_error; |
1842 | ||
7fcb1804 | 1843 | /* Seek past the end of the current record. */ |
6de9cd9a | 1844 | |
5e805e44 | 1845 | if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE) |
6de9cd9a DN |
1846 | goto io_error; |
1847 | ||
1848 | break; | |
1849 | ||
1850 | case FORMATTED_SEQUENTIAL: | |
59154ed2 | 1851 | |
5e805e44 | 1852 | if (dtp->u.p.current_unit->bytes_left == 0) |
59154ed2 JD |
1853 | break; |
1854 | ||
5e805e44 | 1855 | if (is_internal_unit (dtp)) |
59154ed2 | 1856 | { |
5e805e44 | 1857 | if (is_array_io (dtp)) |
59154ed2 | 1858 | { |
494ef4c2 JD |
1859 | length = (int) dtp->u.p.current_unit->bytes_left; |
1860 | ||
1861 | /* If the farthest position reached is greater than current | |
1862 | position, adjust the position and set length to pad out | |
1863 | whats left. Otherwise just pad whats left. | |
1864 | (for character array unit) */ | |
1865 | m = dtp->u.p.current_unit->recl | |
1866 | - dtp->u.p.current_unit->bytes_left; | |
1867 | if (max_pos > m) | |
1868 | { | |
1869 | length = (int) (max_pos - m); | |
1870 | p = salloc_w (dtp->u.p.current_unit->s, &length); | |
1871 | length = (int) (dtp->u.p.current_unit->recl - max_pos); | |
1872 | } | |
1873 | ||
82b8244c | 1874 | if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) |
59154ed2 | 1875 | { |
5e805e44 | 1876 | generate_error (&dtp->common, ERROR_END, NULL); |
aed6ee24 | 1877 | return; |
59154ed2 | 1878 | } |
5e805e44 JJ |
1879 | |
1880 | /* Now that the current record has been padded out, | |
1881 | determine where the next record in the array is. */ | |
5e805e44 JJ |
1882 | record = next_array_record (dtp, dtp->u.p.current_unit->ls); |
1883 | ||
1884 | /* Now seek to this record */ | |
1885 | record = record * dtp->u.p.current_unit->recl; | |
1886 | ||
1887 | if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) | |
844234fb JD |
1888 | { |
1889 | generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); | |
1890 | return; | |
1891 | } | |
5e805e44 JJ |
1892 | |
1893 | dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
59154ed2 JD |
1894 | } |
1895 | else | |
1896 | { | |
1897 | length = 1; | |
494ef4c2 JD |
1898 | |
1899 | /* If this is the last call to next_record move to the farthest | |
1900 | position reached and set length to pad out the remainder | |
1901 | of the record. (for character scaler unit) */ | |
1902 | if (done) | |
1903 | { | |
1904 | m = dtp->u.p.current_unit->recl | |
1905 | - dtp->u.p.current_unit->bytes_left; | |
1906 | if (max_pos > m) | |
1907 | { | |
1908 | length = (int) (max_pos - m); | |
1909 | p = salloc_w (dtp->u.p.current_unit->s, &length); | |
1910 | length = (int) (dtp->u.p.current_unit->recl - max_pos); | |
1911 | } | |
1912 | else | |
1913 | length = (int) dtp->u.p.current_unit->bytes_left; | |
1914 | } | |
82b8244c | 1915 | if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) |
494ef4c2 JD |
1916 | { |
1917 | generate_error (&dtp->common, ERROR_END, NULL); | |
1918 | return; | |
1919 | } | |
59154ed2 | 1920 | } |
494ef4c2 | 1921 | } |
59154ed2 JD |
1922 | else |
1923 | { | |
494ef4c2 JD |
1924 | /* If this is the last call to next_record move to the farthest |
1925 | position reached in preparation for completing the record. | |
1926 | (for file unit) */ | |
1927 | if (done) | |
1928 | { | |
1929 | m = dtp->u.p.current_unit->recl - | |
1930 | dtp->u.p.current_unit->bytes_left; | |
1931 | if (max_pos > m) | |
1932 | { | |
1933 | length = (int) (max_pos - m); | |
1934 | p = salloc_w (dtp->u.p.current_unit->s, &length); | |
1935 | } | |
1936 | } | |
82b8244c JB |
1937 | size_t len; |
1938 | const char crlf[] = "\r\n"; | |
3c127520 | 1939 | #ifdef HAVE_CRLF |
82b8244c | 1940 | len = 2; |
3c127520 | 1941 | #else |
82b8244c | 1942 | len = 1; |
3c127520 | 1943 | #endif |
82b8244c | 1944 | if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0) |
be0cc7e2 PT |
1945 | goto io_error; |
1946 | } | |
6de9cd9a | 1947 | |
6de9cd9a DN |
1948 | break; |
1949 | ||
1950 | io_error: | |
5e805e44 | 1951 | generate_error (&dtp->common, ERROR_OS, NULL); |
6de9cd9a DN |
1952 | break; |
1953 | } | |
1954 | } | |
1955 | ||
7fcb1804 TS |
1956 | /* Position to the next record, which means moving to the end of the |
1957 | current record. This can happen under several different | |
1958 | conditions. If the done flag is not set, we get ready to process | |
1959 | the next record. */ | |
6de9cd9a DN |
1960 | |
1961 | void | |
5e805e44 | 1962 | next_record (st_parameter_dt *dtp, int done) |
6de9cd9a | 1963 | { |
7fcb1804 | 1964 | gfc_offset fp; /* File position. */ |
6de9cd9a | 1965 | |
5e805e44 | 1966 | dtp->u.p.current_unit->read_bad = 0; |
6de9cd9a | 1967 | |
5e805e44 JJ |
1968 | if (dtp->u.p.mode == READING) |
1969 | next_record_r (dtp); | |
6de9cd9a | 1970 | else |
494ef4c2 | 1971 | next_record_w (dtp, done); |
6de9cd9a | 1972 | |
b1a80705 | 1973 | /* keep position up to date for INQUIRE */ |
5e805e44 | 1974 | dtp->u.p.current_unit->flags.position = POSITION_ASIS; |
b1a80705 | 1975 | |
5e805e44 JJ |
1976 | dtp->u.p.current_unit->current_record = 0; |
1977 | if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) | |
0fa1b65c | 1978 | { |
5e805e44 | 1979 | fp = file_position (dtp->u.p.current_unit->s); |
0fa1b65c | 1980 | /* Calculate next record, rounding up partial records. */ |
5e805e44 JJ |
1981 | dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1) |
1982 | / dtp->u.p.current_unit->recl; | |
0fa1b65c | 1983 | } |
6de9cd9a | 1984 | else |
5e805e44 | 1985 | dtp->u.p.current_unit->last_record++; |
6de9cd9a DN |
1986 | |
1987 | if (!done) | |
5e805e44 | 1988 | pre_position (dtp); |
6de9cd9a DN |
1989 | } |
1990 | ||
1991 | ||
1992 | /* Finalize the current data transfer. For a nonadvancing transfer, | |
5615e8cd | 1993 | this means advancing to the next record. For internal units close the |
965eec16 | 1994 | stream associated with the unit. */ |
6de9cd9a DN |
1995 | |
1996 | static void | |
5e805e44 | 1997 | finalize_transfer (st_parameter_dt *dtp) |
6de9cd9a | 1998 | { |
5e805e44 JJ |
1999 | jmp_buf eof_jump; |
2000 | GFC_INTEGER_4 cf = dtp->common.flags; | |
59afe4b4 | 2001 | |
5e805e44 | 2002 | if (dtp->u.p.eor_condition) |
59afe4b4 | 2003 | { |
5e805e44 | 2004 | generate_error (&dtp->common, ERROR_EOR, NULL); |
59afe4b4 TK |
2005 | return; |
2006 | } | |
2007 | ||
5e805e44 | 2008 | if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) |
0e69bba9 TK |
2009 | return; |
2010 | ||
5e805e44 JJ |
2011 | if ((dtp->u.p.ionml != NULL) |
2012 | && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) | |
6de9cd9a | 2013 | { |
5e805e44 JJ |
2014 | if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0) |
2015 | namelist_read (dtp); | |
6de9cd9a | 2016 | else |
5e805e44 | 2017 | namelist_write (dtp); |
6de9cd9a DN |
2018 | } |
2019 | ||
5e805e44 JJ |
2020 | dtp->u.p.transfer = NULL; |
2021 | if (dtp->u.p.current_unit == NULL) | |
6de9cd9a DN |
2022 | return; |
2023 | ||
5e805e44 JJ |
2024 | dtp->u.p.eof_jump = &eof_jump; |
2025 | if (setjmp (eof_jump)) | |
bd72d66c | 2026 | { |
5e805e44 | 2027 | generate_error (&dtp->common, ERROR_END, NULL); |
bd72d66c PB |
2028 | return; |
2029 | } | |
2030 | ||
5e805e44 JJ |
2031 | if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING) |
2032 | finish_list_read (dtp); | |
6de9cd9a DN |
2033 | else |
2034 | { | |
0a736393 | 2035 | dtp->u.p.current_unit->current_record = 0; |
5e805e44 | 2036 | if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) |
000aa32a JB |
2037 | { |
2038 | /* Most systems buffer lines, so force the partial record | |
2039 | to be written out. */ | |
5e805e44 JJ |
2040 | flush (dtp->u.p.current_unit->s); |
2041 | dtp->u.p.seen_dollar = 0; | |
000aa32a JB |
2042 | return; |
2043 | } | |
2044 | ||
5e805e44 | 2045 | next_record (dtp, 1); |
6de9cd9a DN |
2046 | } |
2047 | ||
5e805e44 | 2048 | sfree (dtp->u.p.current_unit->s); |
5615e8cd | 2049 | |
5e805e44 | 2050 | if (is_internal_unit (dtp)) |
965eec16 | 2051 | { |
5e805e44 JJ |
2052 | if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL) |
2053 | free_mem (dtp->u.p.current_unit->ls); | |
2054 | sclose (dtp->u.p.current_unit->s); | |
965eec16 | 2055 | } |
6de9cd9a DN |
2056 | } |
2057 | ||
2058 | ||
8750f9cd JB |
2059 | /* Transfer function for IOLENGTH. It doesn't actually do any |
2060 | data transfer, it just updates the length counter. */ | |
2061 | ||
2062 | static void | |
5e805e44 | 2063 | iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), |
e5ef4b3b JB |
2064 | void *dest __attribute__ ((unused)), |
2065 | int kind __attribute__((unused)), | |
2066 | size_t size, size_t nelems) | |
8750f9cd | 2067 | { |
5e805e44 JJ |
2068 | if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) |
2069 | *dtp->iolength += (GFC_INTEGER_4) size * nelems; | |
8750f9cd JB |
2070 | } |
2071 | ||
2072 | ||
2073 | /* Initialize the IOLENGTH data transfer. This function is in essence | |
2074 | a very much simplified version of data_transfer_init(), because it | |
2075 | doesn't have to deal with units at all. */ | |
2076 | ||
2077 | static void | |
5e805e44 | 2078 | iolength_transfer_init (st_parameter_dt *dtp) |
8750f9cd | 2079 | { |
5e805e44 JJ |
2080 | if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) |
2081 | *dtp->iolength = 0; | |
8750f9cd | 2082 | |
5e805e44 | 2083 | memset (&dtp->u.p, 0, sizeof (dtp->u.p)); |
8750f9cd JB |
2084 | |
2085 | /* Set up the subroutine that will handle the transfers. */ | |
2086 | ||
5e805e44 | 2087 | dtp->u.p.transfer = iolength_transfer; |
8750f9cd JB |
2088 | } |
2089 | ||
2090 | ||
2091 | /* Library entry point for the IOLENGTH form of the INQUIRE | |
2092 | statement. The IOLENGTH form requires no I/O to be performed, but | |
2093 | it must still be a runtime library call so that we can determine | |
2094 | the iolength for dynamic arrays and such. */ | |
2095 | ||
5e805e44 | 2096 | extern void st_iolength (st_parameter_dt *); |
7d7b8bfe RH |
2097 | export_proto(st_iolength); |
2098 | ||
8750f9cd | 2099 | void |
5e805e44 | 2100 | st_iolength (st_parameter_dt *dtp) |
8750f9cd | 2101 | { |
5e805e44 JJ |
2102 | library_start (&dtp->common); |
2103 | iolength_transfer_init (dtp); | |
8750f9cd JB |
2104 | } |
2105 | ||
5e805e44 | 2106 | extern void st_iolength_done (st_parameter_dt *); |
7d7b8bfe RH |
2107 | export_proto(st_iolength_done); |
2108 | ||
8750f9cd | 2109 | void |
5e805e44 | 2110 | st_iolength_done (st_parameter_dt *dtp __attribute__((unused))) |
8750f9cd | 2111 | { |
5e805e44 JJ |
2112 | free_ionml (dtp); |
2113 | if (dtp->u.p.scratch != NULL) | |
2114 | free_mem (dtp->u.p.scratch); | |
8750f9cd JB |
2115 | library_end (); |
2116 | } | |
2117 | ||
2118 | ||
7fcb1804 | 2119 | /* The READ statement. */ |
6de9cd9a | 2120 | |
5e805e44 | 2121 | extern void st_read (st_parameter_dt *); |
7d7b8bfe RH |
2122 | export_proto(st_read); |
2123 | ||
6de9cd9a | 2124 | void |
5e805e44 | 2125 | st_read (st_parameter_dt *dtp) |
6de9cd9a | 2126 | { |
be0cc7e2 | 2127 | |
5e805e44 | 2128 | library_start (&dtp->common); |
6de9cd9a | 2129 | |
5e805e44 | 2130 | data_transfer_init (dtp, 1); |
6de9cd9a DN |
2131 | |
2132 | /* Handle complications dealing with the endfile record. It is | |
7fcb1804 TS |
2133 | significant that this is the only place where ERROR_END is |
2134 | generated. Reading an end of file elsewhere is either end of | |
2135 | record or an I/O error. */ | |
6de9cd9a | 2136 | |
5e805e44 JJ |
2137 | if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) |
2138 | switch (dtp->u.p.current_unit->endfile) | |
6de9cd9a DN |
2139 | { |
2140 | case NO_ENDFILE: | |
2141 | break; | |
2142 | ||
2143 | case AT_ENDFILE: | |
5e805e44 | 2144 | if (!is_internal_unit (dtp)) |
be0cc7e2 | 2145 | { |
5e805e44 JJ |
2146 | generate_error (&dtp->common, ERROR_END, NULL); |
2147 | dtp->u.p.current_unit->endfile = AFTER_ENDFILE; | |
2148 | dtp->u.p.current_unit->current_record = 0; | |
be0cc7e2 | 2149 | } |
6de9cd9a DN |
2150 | break; |
2151 | ||
2152 | case AFTER_ENDFILE: | |
5e805e44 JJ |
2153 | generate_error (&dtp->common, ERROR_ENDFILE, NULL); |
2154 | dtp->u.p.current_unit->current_record = 0; | |
6de9cd9a DN |
2155 | break; |
2156 | } | |
2157 | } | |
2158 | ||
5e805e44 | 2159 | extern void st_read_done (st_parameter_dt *); |
7d7b8bfe | 2160 | export_proto(st_read_done); |
6de9cd9a DN |
2161 | |
2162 | void | |
5e805e44 | 2163 | st_read_done (st_parameter_dt *dtp) |
6de9cd9a | 2164 | { |
5e805e44 JJ |
2165 | finalize_transfer (dtp); |
2166 | free_format_data (dtp); | |
2167 | free_ionml (dtp); | |
2168 | if (dtp->u.p.scratch != NULL) | |
2169 | free_mem (dtp->u.p.scratch); | |
2170 | if (dtp->u.p.current_unit != NULL) | |
2171 | unlock_unit (dtp->u.p.current_unit); | |
6de9cd9a DN |
2172 | library_end (); |
2173 | } | |
2174 | ||
5e805e44 | 2175 | extern void st_write (st_parameter_dt *); |
7d7b8bfe | 2176 | export_proto(st_write); |
6de9cd9a DN |
2177 | |
2178 | void | |
5e805e44 | 2179 | st_write (st_parameter_dt *dtp) |
6de9cd9a | 2180 | { |
5e805e44 JJ |
2181 | library_start (&dtp->common); |
2182 | data_transfer_init (dtp, 0); | |
6de9cd9a DN |
2183 | } |
2184 | ||
5e805e44 | 2185 | extern void st_write_done (st_parameter_dt *); |
7d7b8bfe | 2186 | export_proto(st_write_done); |
6de9cd9a DN |
2187 | |
2188 | void | |
5e805e44 | 2189 | st_write_done (st_parameter_dt *dtp) |
6de9cd9a | 2190 | { |
5e805e44 | 2191 | finalize_transfer (dtp); |
6de9cd9a | 2192 | |
7fcb1804 | 2193 | /* Deal with endfile conditions associated with sequential files. */ |
6de9cd9a | 2194 | |
99c6db71 JD |
2195 | if (dtp->u.p.current_unit != NULL |
2196 | && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) | |
5e805e44 | 2197 | switch (dtp->u.p.current_unit->endfile) |
6de9cd9a | 2198 | { |
7fcb1804 | 2199 | case AT_ENDFILE: /* Remain at the endfile record. */ |
6de9cd9a DN |
2200 | break; |
2201 | ||
2202 | case AFTER_ENDFILE: | |
5e805e44 | 2203 | dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */ |
6de9cd9a DN |
2204 | break; |
2205 | ||
e1c74af0 | 2206 | case NO_ENDFILE: |
99c6db71 JD |
2207 | /* Get rid of whatever is after this record. */ |
2208 | flush (dtp->u.p.current_unit->s); | |
2209 | if (struncate (dtp->u.p.current_unit->s) == FAILURE) | |
2210 | generate_error (&dtp->common, ERROR_OS, NULL); | |
6de9cd9a | 2211 | |
5e805e44 | 2212 | dtp->u.p.current_unit->endfile = AT_ENDFILE; |
6de9cd9a DN |
2213 | break; |
2214 | } | |
2215 | ||
5e805e44 JJ |
2216 | free_format_data (dtp); |
2217 | free_ionml (dtp); | |
2218 | if (dtp->u.p.scratch != NULL) | |
2219 | free_mem (dtp->u.p.scratch); | |
2220 | if (dtp->u.p.current_unit != NULL) | |
2221 | unlock_unit (dtp->u.p.current_unit); | |
6de9cd9a DN |
2222 | library_end (); |
2223 | } | |
2224 | ||
29dc5138 PT |
2225 | /* Receives the scalar information for namelist objects and stores it |
2226 | in a linked list of namelist_info types. */ | |
6de9cd9a | 2227 | |
5e805e44 JJ |
2228 | extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *, |
2229 | GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4); | |
944e86ee AJ |
2230 | export_proto(st_set_nml_var); |
2231 | ||
2232 | ||
29dc5138 | 2233 | void |
5e805e44 JJ |
2234 | st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name, |
2235 | GFC_INTEGER_4 len, gfc_charlen_type string_length, | |
2236 | GFC_INTEGER_4 dtype) | |
6de9cd9a | 2237 | { |
29dc5138 PT |
2238 | namelist_info *t1 = NULL; |
2239 | namelist_info *nml; | |
2240 | ||
2241 | nml = (namelist_info*) get_mem (sizeof (namelist_info)); | |
2242 | ||
6de9cd9a | 2243 | nml->mem_pos = var_addr; |
29dc5138 PT |
2244 | |
2245 | nml->var_name = (char*) get_mem (strlen (var_name) + 1); | |
2246 | strcpy (nml->var_name, var_name); | |
2247 | ||
2248 | nml->len = (int) len; | |
2249 | nml->string_length = (index_type) string_length; | |
2250 | ||
2251 | nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK); | |
2252 | nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT); | |
2253 | nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT); | |
2254 | ||
2255 | if (nml->var_rank > 0) | |
3bc268e6 | 2256 | { |
29dc5138 PT |
2257 | nml->dim = (descriptor_dimension*) |
2258 | get_mem (nml->var_rank * sizeof (descriptor_dimension)); | |
965eec16 JD |
2259 | nml->ls = (array_loop_spec*) |
2260 | get_mem (nml->var_rank * sizeof (array_loop_spec)); | |
3bc268e6 VL |
2261 | } |
2262 | else | |
2263 | { | |
29dc5138 PT |
2264 | nml->dim = NULL; |
2265 | nml->ls = NULL; | |
3bc268e6 VL |
2266 | } |
2267 | ||
6de9cd9a DN |
2268 | nml->next = NULL; |
2269 | ||
5e805e44 JJ |
2270 | if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0) |
2271 | { | |
2272 | dtp->common.flags |= IOPARM_DT_IONML_SET; | |
2273 | dtp->u.p.ionml = nml; | |
2274 | } | |
6de9cd9a DN |
2275 | else |
2276 | { | |
5e805e44 | 2277 | for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next); |
29dc5138 | 2278 | t1->next = nml; |
6de9cd9a DN |
2279 | } |
2280 | } | |
2281 | ||
29dc5138 | 2282 | /* Store the dimensional information for the namelist object. */ |
5e805e44 JJ |
2283 | extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4, |
2284 | GFC_INTEGER_4, GFC_INTEGER_4, | |
2285 | GFC_INTEGER_4); | |
944e86ee | 2286 | export_proto(st_set_nml_var_dim); |
7d7b8bfe | 2287 | |
6de9cd9a | 2288 | void |
5e805e44 JJ |
2289 | st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim, |
2290 | GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound, | |
2291 | GFC_INTEGER_4 ubound) | |
6de9cd9a | 2292 | { |
29dc5138 PT |
2293 | namelist_info * nml; |
2294 | int n; | |
6de9cd9a | 2295 | |
29dc5138 | 2296 | n = (int)n_dim; |
6de9cd9a | 2297 | |
5e805e44 | 2298 | for (nml = dtp->u.p.ionml; nml->next; nml = nml->next); |
6de9cd9a | 2299 | |
29dc5138 PT |
2300 | nml->dim[n].stride = (ssize_t)stride; |
2301 | nml->dim[n].lbound = (ssize_t)lbound; | |
2302 | nml->dim[n].ubound = (ssize_t)ubound; | |
6de9cd9a | 2303 | } |
181c9f4a TK |
2304 | |
2305 | /* Reverse memcpy - used for byte swapping. */ | |
2306 | ||
2307 | void reverse_memcpy (void *dest, const void *src, size_t n) | |
2308 | { | |
2309 | char *d, *s; | |
2310 | size_t i; | |
2311 | ||
2312 | d = (char *) dest; | |
2313 | s = (char *) src + n - 1; | |
2314 | ||
2315 | /* Write with ascending order - this is likely faster | |
2316 | on modern architectures because of write combining. */ | |
2317 | for (i=0; i<n; i++) | |
2318 | *(d++) = *(s--); | |
2319 | } |