1 /* Copyright (C) 2002-2016 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
5
6 This file is part of the GNU Fortran runtime library (libgfortran).
7
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
12
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
26
27
28 /* transfer.c -- Top level handling of data transfer statements. */
29
30 #include "io.h"
31 #include "fbuf.h"
32 #include "format.h"
33 #include "unix.h"
34 #include <string.h>
35 #include <assert.h>
36 #include <stdlib.h>
37 #include <errno.h>
38
39
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
42
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
47
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
50 statement. For READ (and for backwards compatibily: for WRITE), one has
51
52 transfer_integer
53 transfer_logical
54 transfer_character
55 transfer_character_wide
56 transfer_real
57 transfer_complex
58 transfer_real128
59 transfer_complex128
60
61 and for WRITE
62
63 transfer_integer_write
64 transfer_logical_write
65 transfer_character_write
66 transfer_character_wide_write
67 transfer_real_write
68 transfer_complex_write
69 transfer_real128_write
70 transfer_complex128_write
71
72 These subroutines do not return status. The *128 functions
73 are in the file transfer128.c.
74
75 The last call is a call to st_[read|write]_done(). While
76 something can easily go wrong with the initial st_read() or
77 st_write(), an error inhibits any data from actually being
78 transferred. */
79
80 extern void transfer_integer (st_parameter_dt *, void *, int);
81 export_proto(transfer_integer);
82
83 extern void transfer_integer_write (st_parameter_dt *, void *, int);
84 export_proto(transfer_integer_write);
85
86 extern void transfer_real (st_parameter_dt *, void *, int);
87 export_proto(transfer_real);
88
89 extern void transfer_real_write (st_parameter_dt *, void *, int);
90 export_proto(transfer_real_write);
91
92 extern void transfer_logical (st_parameter_dt *, void *, int);
93 export_proto(transfer_logical);
94
95 extern void transfer_logical_write (st_parameter_dt *, void *, int);
96 export_proto(transfer_logical_write);
97
98 extern void transfer_character (st_parameter_dt *, void *, int);
99 export_proto(transfer_character);
100
101 extern void transfer_character_write (st_parameter_dt *, void *, int);
102 export_proto(transfer_character_write);
103
104 extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
105 export_proto(transfer_character_wide);
106
107 extern void transfer_character_wide_write (st_parameter_dt *,
108 void *, int, int);
109 export_proto(transfer_character_wide_write);
110
111 extern void transfer_complex (st_parameter_dt *, void *, int);
112 export_proto(transfer_complex);
113
114 extern void transfer_complex_write (st_parameter_dt *, void *, int);
115 export_proto(transfer_complex_write);
116
117 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
118 gfc_charlen_type);
119 export_proto(transfer_array);
120
121 extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
122 gfc_charlen_type);
123 export_proto(transfer_array_write);
124
125 static void us_read (st_parameter_dt *, int);
126 static void us_write (st_parameter_dt *, int);
127 static void next_record_r_unf (st_parameter_dt *, int);
128 static void next_record_w_unf (st_parameter_dt *, int);
129
130 static const st_option advance_opt[] = {
131 {"yes", ADVANCE_YES},
132 {"no", ADVANCE_NO},
133 {NULL, 0}
134 };
135
136
137 static const st_option decimal_opt[] = {
138 {"point", DECIMAL_POINT},
139 {"comma", DECIMAL_COMMA},
140 {NULL, 0}
141 };
142
143 static const st_option round_opt[] = {
144 {"up", ROUND_UP},
145 {"down", ROUND_DOWN},
146 {"zero", ROUND_ZERO},
147 {"nearest", ROUND_NEAREST},
148 {"compatible", ROUND_COMPATIBLE},
149 {"processor_defined", ROUND_PROCDEFINED},
150 {NULL, 0}
151 };
152
153
154 static const st_option sign_opt[] = {
155 {"plus", SIGN_SP},
156 {"suppress", SIGN_SS},
157 {"processor_defined", SIGN_S},
158 {NULL, 0}
159 };
160
161 static const st_option blank_opt[] = {
162 {"null", BLANK_NULL},
163 {"zero", BLANK_ZERO},
164 {NULL, 0}
165 };
166
167 static const st_option delim_opt[] = {
168 {"apostrophe", DELIM_APOSTROPHE},
169 {"quote", DELIM_QUOTE},
170 {"none", DELIM_NONE},
171 {NULL, 0}
172 };
173
174 static const st_option pad_opt[] = {
175 {"yes", PAD_YES},
176 {"no", PAD_NO},
177 {NULL, 0}
178 };
179
180 typedef enum
181 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
182 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
183 }
184 file_mode;
185
186
187 static file_mode
current_mode(st_parameter_dt * dtp)188 current_mode (st_parameter_dt *dtp)
189 {
190 file_mode m;
191
192 m = FORM_UNSPECIFIED;
193
194 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
195 {
196 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
197 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
198 }
199 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
200 {
201 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
202 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
203 }
204 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
205 {
206 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
207 FORMATTED_STREAM : UNFORMATTED_STREAM;
208 }
209
210 return m;
211 }
212
213
214 /* Mid level data transfer statements. */
215
216 /* Read sequential file - internal unit */
217
218 static char *
read_sf_internal(st_parameter_dt * dtp,int * length)219 read_sf_internal (st_parameter_dt *dtp, int * length)
220 {
221 static char *empty_string[0];
222 char *base;
223 int lorig;
224
225 /* Zero size array gives internal unit len of 0. Nothing to read. */
226 if (dtp->internal_unit_len == 0
227 && dtp->u.p.current_unit->pad_status == PAD_NO)
228 hit_eof (dtp);
229
230 /* If we have seen an eor previously, return a length of 0. The
231 caller is responsible for correctly padding the input field. */
232 if (dtp->u.p.sf_seen_eor)
233 {
234 *length = 0;
235 /* Just return something that isn't a NULL pointer, otherwise the
236 caller thinks an error occurred. */
237 return (char*) empty_string;
238 }
239
240 lorig = *length;
241 if (is_char4_unit(dtp))
242 {
243 int i;
244 gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
245 length);
246 base = fbuf_alloc (dtp->u.p.current_unit, lorig);
247 for (i = 0; i < *length; i++, p++)
248 base[i] = *p > 255 ? '?' : (unsigned char) *p;
249 }
250 else
251 base = mem_alloc_r (dtp->u.p.current_unit->s, length);
252
253 if (unlikely (lorig > *length))
254 {
255 hit_eof (dtp);
256 return NULL;
257 }
258
259 dtp->u.p.current_unit->bytes_left -= *length;
260
261 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
262 dtp->u.p.size_used += (GFC_IO_INT) *length;
263
264 return base;
265
266 }
267
268 /* When reading sequential formatted records we have a problem. We
269 don't know how long the line is until we read the trailing newline,
270 and we don't want to read too much. If we read too much, we might
271 have to do a physical seek backwards depending on how much data is
272 present, and devices like terminals aren't seekable and would cause
273 an I/O error.
274
275 Given this, the solution is to read a byte at a time, stopping if
276 we hit the newline. For small allocations, we use a static buffer.
277 For larger allocations, we are forced to allocate memory on the
278 heap. Hopefully this won't happen very often. */
279
280 /* Read sequential file - external unit */
281
282 static char *
read_sf(st_parameter_dt * dtp,int * length)283 read_sf (st_parameter_dt *dtp, int * length)
284 {
285 static char *empty_string[0];
286 int q, q2;
287 int n, lorig, seen_comma;
288
289 /* If we have seen an eor previously, return a length of 0. The
290 caller is responsible for correctly padding the input field. */
291 if (dtp->u.p.sf_seen_eor)
292 {
293 *length = 0;
294 /* Just return something that isn't a NULL pointer, otherwise the
295 caller thinks an error occurred. */
296 return (char*) empty_string;
297 }
298
299 n = seen_comma = 0;
300
301 /* Read data into format buffer and scan through it. */
302 lorig = *length;
303
304 while (n < *length)
305 {
306 q = fbuf_getc (dtp->u.p.current_unit);
307 if (q == EOF)
308 break;
309 else if (q == '\n' || q == '\r')
310 {
311 /* Unexpected end of line. Set the position. */
312 dtp->u.p.sf_seen_eor = 1;
313
314 /* If we see an EOR during non-advancing I/O, we need to skip
315 the rest of the I/O statement. Set the corresponding flag. */
316 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
317 dtp->u.p.eor_condition = 1;
318
319 /* If we encounter a CR, it might be a CRLF. */
320 if (q == '\r') /* Probably a CRLF */
321 {
322 /* See if there is an LF. */
323 q2 = fbuf_getc (dtp->u.p.current_unit);
324 if (q2 == '\n')
325 dtp->u.p.sf_seen_eor = 2;
326 else if (q2 != EOF) /* Oops, seek back. */
327 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
328 }
329
330 /* Without padding, terminate the I/O statement without assigning
331 the value. With padding, the value still needs to be assigned,
332 so we can just continue with a short read. */
333 if (dtp->u.p.current_unit->pad_status == PAD_NO)
334 {
335 generate_error (&dtp->common, LIBERROR_EOR, NULL);
336 return NULL;
337 }
338
339 *length = n;
340 goto done;
341 }
342 /* Short circuit the read if a comma is found during numeric input.
343 The flag is set to zero during character reads so that commas in
344 strings are not ignored */
345 else if (q == ',')
346 if (dtp->u.p.sf_read_comma == 1)
347 {
348 seen_comma = 1;
349 notify_std (&dtp->common, GFC_STD_GNU,
350 "Comma in formatted numeric read.");
351 break;
352 }
353 n++;
354 }
355
356 *length = n;
357
358 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
359 some other stuff. Set the relevant flags. */
360 if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
361 {
362 if (n > 0)
363 {
364 if (dtp->u.p.advance_status == ADVANCE_NO)
365 {
366 if (dtp->u.p.current_unit->pad_status == PAD_NO)
367 {
368 hit_eof (dtp);
369 return NULL;
370 }
371 else
372 dtp->u.p.eor_condition = 1;
373 }
374 else
375 dtp->u.p.at_eof = 1;
376 }
377 else if (dtp->u.p.advance_status == ADVANCE_NO
378 || dtp->u.p.current_unit->pad_status == PAD_NO
379 || dtp->u.p.current_unit->bytes_left
380 == dtp->u.p.current_unit->recl)
381 {
382 hit_eof (dtp);
383 return NULL;
384 }
385 }
386
387 done:
388
389 dtp->u.p.current_unit->bytes_left -= n;
390
391 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
392 dtp->u.p.size_used += (GFC_IO_INT) n;
393
394 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
395 fbuf_getc might reallocate the buffer. So return current pointer
396 minus all the advances, which is n plus up to two characters
397 of newline or comma. */
398 return fbuf_getptr (dtp->u.p.current_unit)
399 - n - dtp->u.p.sf_seen_eor - seen_comma;
400 }
401
402
403 /* Function for reading the next couple of bytes from the current
404 file, advancing the current position. We return NULL on end of record or
405 end of file. This function is only for formatted I/O, unformatted uses
406 read_block_direct.
407
408 If the read is short, then it is because the current record does not
409 have enough data to satisfy the read request and the file was
410 opened with PAD=YES. The caller must assume tailing spaces for
411 short reads. */
412
413 void *
read_block_form(st_parameter_dt * dtp,int * nbytes)414 read_block_form (st_parameter_dt *dtp, int * nbytes)
415 {
416 char *source;
417 int norig;
418
419 if (!is_stream_io (dtp))
420 {
421 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
422 {
423 /* For preconnected units with default record length, set bytes left
424 to unit record length and proceed, otherwise error. */
425 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
426 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
427 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
428 else
429 {
430 if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)
431 && !is_internal_unit (dtp))
432 {
433 /* Not enough data left. */
434 generate_error (&dtp->common, LIBERROR_EOR, NULL);
435 return NULL;
436 }
437 }
438
439 if (unlikely (dtp->u.p.current_unit->bytes_left == 0
440 && !is_internal_unit(dtp)))
441 {
442 hit_eof (dtp);
443 return NULL;
444 }
445
446 *nbytes = dtp->u.p.current_unit->bytes_left;
447 }
448 }
449
450 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
451 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
452 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
453 {
454 if (is_internal_unit (dtp))
455 source = read_sf_internal (dtp, nbytes);
456 else
457 source = read_sf (dtp, nbytes);
458
459 dtp->u.p.current_unit->strm_pos +=
460 (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
461 return source;
462 }
463
464 /* If we reach here, we can assume it's direct access. */
465
466 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
467
468 norig = *nbytes;
469 source = fbuf_read (dtp->u.p.current_unit, nbytes);
470 fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
471
472 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
473 dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
474
475 if (norig != *nbytes)
476 {
477 /* Short read, this shouldn't happen. */
478 if (dtp->u.p.current_unit->pad_status == PAD_NO)
479 {
480 generate_error (&dtp->common, LIBERROR_EOR, NULL);
481 source = NULL;
482 }
483 }
484
485 dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
486
487 return source;
488 }
489
490
491 /* Read a block from a character(kind=4) internal unit, to be transferred into
492 a character(kind=4) variable. Note: Portions of this code borrowed from
493 read_sf_internal. */
494 void *
read_block_form4(st_parameter_dt * dtp,int * nbytes)495 read_block_form4 (st_parameter_dt *dtp, int * nbytes)
496 {
497 static gfc_char4_t *empty_string[0];
498 gfc_char4_t *source;
499 int lorig;
500
501 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
502 *nbytes = dtp->u.p.current_unit->bytes_left;
503
504 /* Zero size array gives internal unit len of 0. Nothing to read. */
505 if (dtp->internal_unit_len == 0
506 && dtp->u.p.current_unit->pad_status == PAD_NO)
507 hit_eof (dtp);
508
509 /* If we have seen an eor previously, return a length of 0. The
510 caller is responsible for correctly padding the input field. */
511 if (dtp->u.p.sf_seen_eor)
512 {
513 *nbytes = 0;
514 /* Just return something that isn't a NULL pointer, otherwise the
515 caller thinks an error occurred. */
516 return empty_string;
517 }
518
519 lorig = *nbytes;
520 source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes);
521
522 if (unlikely (lorig > *nbytes))
523 {
524 hit_eof (dtp);
525 return NULL;
526 }
527
528 dtp->u.p.current_unit->bytes_left -= *nbytes;
529
530 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
531 dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
532
533 return source;
534 }
535
536
537 /* Reads a block directly into application data space. This is for
538 unformatted files. */
539
540 static void
read_block_direct(st_parameter_dt * dtp,void * buf,size_t nbytes)541 read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
542 {
543 ssize_t to_read_record;
544 ssize_t have_read_record;
545 ssize_t to_read_subrecord;
546 ssize_t have_read_subrecord;
547 int short_record;
548
549 if (is_stream_io (dtp))
550 {
551 have_read_record = sread (dtp->u.p.current_unit->s, buf,
552 nbytes);
553 if (unlikely (have_read_record < 0))
554 {
555 generate_error (&dtp->common, LIBERROR_OS, NULL);
556 return;
557 }
558
559 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
560
561 if (unlikely ((ssize_t) nbytes != have_read_record))
562 {
563 /* Short read, e.g. if we hit EOF. For stream files,
564 we have to set the end-of-file condition. */
565 hit_eof (dtp);
566 }
567 return;
568 }
569
570 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
571 {
572 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
573 {
574 short_record = 1;
575 to_read_record = dtp->u.p.current_unit->bytes_left;
576 nbytes = to_read_record;
577 }
578 else
579 {
580 short_record = 0;
581 to_read_record = nbytes;
582 }
583
584 dtp->u.p.current_unit->bytes_left -= to_read_record;
585
586 to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
587 if (unlikely (to_read_record < 0))
588 {
589 generate_error (&dtp->common, LIBERROR_OS, NULL);
590 return;
591 }
592
593 if (to_read_record != (ssize_t) nbytes)
594 {
595 /* Short read, e.g. if we hit EOF. Apparently, we read
596 more than was written to the last record. */
597 return;
598 }
599
600 if (unlikely (short_record))
601 {
602 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
603 }
604 return;
605 }
606
607 /* Unformatted sequential. We loop over the subrecords, reading
608 until the request has been fulfilled or the record has run out
609 of continuation subrecords. */
610
611 /* Check whether we exceed the total record length. */
612
613 if (dtp->u.p.current_unit->flags.has_recl
614 && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left))
615 {
616 to_read_record = dtp->u.p.current_unit->bytes_left;
617 short_record = 1;
618 }
619 else
620 {
621 to_read_record = nbytes;
622 short_record = 0;
623 }
624 have_read_record = 0;
625
626 while(1)
627 {
628 if (dtp->u.p.current_unit->bytes_left_subrecord
629 < (gfc_offset) to_read_record)
630 {
631 to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord;
632 to_read_record -= to_read_subrecord;
633 }
634 else
635 {
636 to_read_subrecord = to_read_record;
637 to_read_record = 0;
638 }
639
640 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
641
642 have_read_subrecord = sread (dtp->u.p.current_unit->s,
643 buf + have_read_record, to_read_subrecord);
644 if (unlikely (have_read_subrecord < 0))
645 {
646 generate_error (&dtp->common, LIBERROR_OS, NULL);
647 return;
648 }
649
650 have_read_record += have_read_subrecord;
651
652 if (unlikely (to_read_subrecord != have_read_subrecord))
653 {
654 /* Short read, e.g. if we hit EOF. This means the record
655 structure has been corrupted, or the trailing record
656 marker would still be present. */
657
658 generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
659 return;
660 }
661
662 if (to_read_record > 0)
663 {
664 if (likely (dtp->u.p.current_unit->continued))
665 {
666 next_record_r_unf (dtp, 0);
667 us_read (dtp, 1);
668 }
669 else
670 {
671 /* Let's make sure the file position is correctly pre-positioned
672 for the next read statement. */
673
674 dtp->u.p.current_unit->current_record = 0;
675 next_record_r_unf (dtp, 0);
676 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
677 return;
678 }
679 }
680 else
681 {
682 /* Normal exit, the read request has been fulfilled. */
683 break;
684 }
685 }
686
687 dtp->u.p.current_unit->bytes_left -= have_read_record;
688 if (unlikely (short_record))
689 {
690 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
691 return;
692 }
693 return;
694 }
695
696
697 /* Function for writing a block of bytes to the current file at the
698 current position, advancing the file pointer. We are given a length
699 and return a pointer to a buffer that the caller must (completely)
700 fill in. Returns NULL on error. */
701
702 void *
write_block(st_parameter_dt * dtp,int length)703 write_block (st_parameter_dt *dtp, int length)
704 {
705 char *dest;
706
707 if (!is_stream_io (dtp))
708 {
709 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
710 {
711 /* For preconnected units with default record length, set bytes left
712 to unit record length and proceed, otherwise error. */
713 if (likely ((dtp->u.p.current_unit->unit_number
714 == options.stdout_unit
715 || dtp->u.p.current_unit->unit_number
716 == options.stderr_unit)
717 && dtp->u.p.current_unit->recl == DEFAULT_RECL))
718 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
719 else
720 {
721 generate_error (&dtp->common, LIBERROR_EOR, NULL);
722 return NULL;
723 }
724 }
725
726 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
727 }
728
729 if (is_internal_unit (dtp))
730 {
731 if (dtp->common.unit) /* char4 internel unit. */
732 {
733 gfc_char4_t *dest4;
734 dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
735 if (dest4 == NULL)
736 {
737 generate_error (&dtp->common, LIBERROR_END, NULL);
738 return NULL;
739 }
740 return dest4;
741 }
742 else
743 dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
744
745 if (dest == NULL)
746 {
747 generate_error (&dtp->common, LIBERROR_END, NULL);
748 return NULL;
749 }
750
751 if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
752 generate_error (&dtp->common, LIBERROR_END, NULL);
753 }
754 else
755 {
756 dest = fbuf_alloc (dtp->u.p.current_unit, length);
757 if (dest == NULL)
758 {
759 generate_error (&dtp->common, LIBERROR_OS, NULL);
760 return NULL;
761 }
762 }
763
764 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
765 dtp->u.p.size_used += (GFC_IO_INT) length;
766
767 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
768
769 return dest;
770 }
771
772
773 /* High level interface to swrite(), taking care of errors. This is only
774 called for unformatted files. There are three cases to consider:
775 Stream I/O, unformatted direct, unformatted sequential. */
776
777 static bool
write_buf(st_parameter_dt * dtp,void * buf,size_t nbytes)778 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
779 {
780
781 ssize_t have_written;
782 ssize_t to_write_subrecord;
783 int short_record;
784
785 /* Stream I/O. */
786
787 if (is_stream_io (dtp))
788 {
789 have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
790 if (unlikely (have_written < 0))
791 {
792 generate_error (&dtp->common, LIBERROR_OS, NULL);
793 return false;
794 }
795
796 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
797
798 return true;
799 }
800
801 /* Unformatted direct access. */
802
803 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
804 {
805 if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes))
806 {
807 generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
808 return false;
809 }
810
811 if (buf == NULL && nbytes == 0)
812 return true;
813
814 have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
815 if (unlikely (have_written < 0))
816 {
817 generate_error (&dtp->common, LIBERROR_OS, NULL);
818 return false;
819 }
820
821 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
822 dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
823
824 return true;
825 }
826
827 /* Unformatted sequential. */
828
829 have_written = 0;
830
831 if (dtp->u.p.current_unit->flags.has_recl
832 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
833 {
834 nbytes = dtp->u.p.current_unit->bytes_left;
835 short_record = 1;
836 }
837 else
838 {
839 short_record = 0;
840 }
841
842 while (1)
843 {
844
845 to_write_subrecord =
846 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
847 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
848
849 dtp->u.p.current_unit->bytes_left_subrecord -=
850 (gfc_offset) to_write_subrecord;
851
852 to_write_subrecord = swrite (dtp->u.p.current_unit->s,
853 buf + have_written, to_write_subrecord);
854 if (unlikely (to_write_subrecord < 0))
855 {
856 generate_error (&dtp->common, LIBERROR_OS, NULL);
857 return false;
858 }
859
860 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
861 nbytes -= to_write_subrecord;
862 have_written += to_write_subrecord;
863
864 if (nbytes == 0)
865 break;
866
867 next_record_w_unf (dtp, 1);
868 us_write (dtp, 1);
869 }
870 dtp->u.p.current_unit->bytes_left -= have_written;
871 if (unlikely (short_record))
872 {
873 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
874 return false;
875 }
876 return true;
877 }
878
879
880 /* Reverse memcpy - used for byte swapping. */
881
882 static void
reverse_memcpy(void * dest,const void * src,size_t n)883 reverse_memcpy (void *dest, const void *src, size_t n)
884 {
885 char *d, *s;
886 size_t i;
887
888 d = (char *) dest;
889 s = (char *) src + n - 1;
890
891 /* Write with ascending order - this is likely faster
892 on modern architectures because of write combining. */
893 for (i=0; i<n; i++)
894 *(d++) = *(s--);
895 }
896
897
898 /* Utility function for byteswapping an array, using the bswap
899 builtins if possible. dest and src can overlap completely, or then
900 they must point to separate objects; partial overlaps are not
901 allowed. */
902
903 static void
bswap_array(void * dest,const void * src,size_t size,size_t nelems)904 bswap_array (void *dest, const void *src, size_t size, size_t nelems)
905 {
906 const char *ps;
907 char *pd;
908
909 switch (size)
910 {
911 case 1:
912 break;
913 case 2:
914 for (size_t i = 0; i < nelems; i++)
915 ((uint16_t*)dest)[i] = __builtin_bswap16 (((uint16_t*)src)[i]);
916 break;
917 case 4:
918 for (size_t i = 0; i < nelems; i++)
919 ((uint32_t*)dest)[i] = __builtin_bswap32 (((uint32_t*)src)[i]);
920 break;
921 case 8:
922 for (size_t i = 0; i < nelems; i++)
923 ((uint64_t*)dest)[i] = __builtin_bswap64 (((uint64_t*)src)[i]);
924 break;
925 case 12:
926 ps = src;
927 pd = dest;
928 for (size_t i = 0; i < nelems; i++)
929 {
930 uint32_t tmp;
931 memcpy (&tmp, ps, 4);
932 *(uint32_t*)pd = __builtin_bswap32 (*(uint32_t*)(ps + 8));
933 *(uint32_t*)(pd + 4) = __builtin_bswap32 (*(uint32_t*)(ps + 4));
934 *(uint32_t*)(pd + 8) = __builtin_bswap32 (tmp);
935 ps += size;
936 pd += size;
937 }
938 break;
939 case 16:
940 ps = src;
941 pd = dest;
942 for (size_t i = 0; i < nelems; i++)
943 {
944 uint64_t tmp;
945 memcpy (&tmp, ps, 8);
946 *(uint64_t*)pd = __builtin_bswap64 (*(uint64_t*)(ps + 8));
947 *(uint64_t*)(pd + 8) = __builtin_bswap64 (tmp);
948 ps += size;
949 pd += size;
950 }
951 break;
952 default:
953 pd = dest;
954 if (dest != src)
955 {
956 ps = src;
957 for (size_t i = 0; i < nelems; i++)
958 {
959 reverse_memcpy (pd, ps, size);
960 ps += size;
961 pd += size;
962 }
963 }
964 else
965 {
966 /* In-place byte swap. */
967 for (size_t i = 0; i < nelems; i++)
968 {
969 char tmp, *low = pd, *high = pd + size - 1;
970 for (size_t j = 0; j < size/2; j++)
971 {
972 tmp = *low;
973 *low = *high;
974 *high = tmp;
975 low++;
976 high--;
977 }
978 pd += size;
979 }
980 }
981 }
982 }
983
984
985 /* Master function for unformatted reads. */
986
987 static void
unformatted_read(st_parameter_dt * dtp,bt type,void * dest,int kind,size_t size,size_t nelems)988 unformatted_read (st_parameter_dt *dtp, bt type,
989 void *dest, int kind, size_t size, size_t nelems)
990 {
991 if (type == BT_CHARACTER)
992 size *= GFC_SIZE_OF_CHAR_KIND(kind);
993 read_block_direct (dtp, dest, size * nelems);
994
995 if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP)
996 && kind != 1)
997 {
998 /* Handle wide chracters. */
999 if (type == BT_CHARACTER)
1000 {
1001 nelems *= size;
1002 size = kind;
1003 }
1004
1005 /* Break up complex into its constituent reals. */
1006 else if (type == BT_COMPLEX)
1007 {
1008 nelems *= 2;
1009 size /= 2;
1010 }
1011 bswap_array (dest, dest, size, nelems);
1012 }
1013 }
1014
1015
1016 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1017 bytes on 64 bit machines. The unused bytes are not initialized and never
1018 used, which can show an error with memory checking analyzers like
1019 valgrind. */
1020
1021 static void
unformatted_write(st_parameter_dt * dtp,bt type,void * source,int kind,size_t size,size_t nelems)1022 unformatted_write (st_parameter_dt *dtp, bt type,
1023 void *source, int kind, size_t size, size_t nelems)
1024 {
1025 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
1026 || kind == 1)
1027 {
1028 size_t stride = type == BT_CHARACTER ?
1029 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1030
1031 write_buf (dtp, source, stride * nelems);
1032 }
1033 else
1034 {
1035 #define BSWAP_BUFSZ 512
1036 char buffer[BSWAP_BUFSZ];
1037 char *p;
1038 size_t nrem;
1039
1040 p = source;
1041
1042 /* Handle wide chracters. */
1043 if (type == BT_CHARACTER && kind != 1)
1044 {
1045 nelems *= size;
1046 size = kind;
1047 }
1048
1049 /* Break up complex into its constituent reals. */
1050 if (type == BT_COMPLEX)
1051 {
1052 nelems *= 2;
1053 size /= 2;
1054 }
1055
1056 /* By now, all complex variables have been split into their
1057 constituent reals. */
1058
1059 nrem = nelems;
1060 do
1061 {
1062 size_t nc;
1063 if (size * nrem > BSWAP_BUFSZ)
1064 nc = BSWAP_BUFSZ / size;
1065 else
1066 nc = nrem;
1067
1068 bswap_array (buffer, p, size, nc);
1069 write_buf (dtp, buffer, size * nc);
1070 p += size * nc;
1071 nrem -= nc;
1072 }
1073 while (nrem > 0);
1074 }
1075 }
1076
1077
1078 /* Return a pointer to the name of a type. */
1079
1080 const char *
type_name(bt type)1081 type_name (bt type)
1082 {
1083 const char *p;
1084
1085 switch (type)
1086 {
1087 case BT_INTEGER:
1088 p = "INTEGER";
1089 break;
1090 case BT_LOGICAL:
1091 p = "LOGICAL";
1092 break;
1093 case BT_CHARACTER:
1094 p = "CHARACTER";
1095 break;
1096 case BT_REAL:
1097 p = "REAL";
1098 break;
1099 case BT_COMPLEX:
1100 p = "COMPLEX";
1101 break;
1102 default:
1103 internal_error (NULL, "type_name(): Bad type");
1104 }
1105
1106 return p;
1107 }
1108
1109
1110 /* Write a constant string to the output.
1111 This is complicated because the string can have doubled delimiters
1112 in it. The length in the format node is the true length. */
1113
1114 static void
write_constant_string(st_parameter_dt * dtp,const fnode * f)1115 write_constant_string (st_parameter_dt *dtp, const fnode *f)
1116 {
1117 char c, delimiter, *p, *q;
1118 int length;
1119
1120 length = f->u.string.length;
1121 if (length == 0)
1122 return;
1123
1124 p = write_block (dtp, length);
1125 if (p == NULL)
1126 return;
1127
1128 q = f->u.string.p;
1129 delimiter = q[-1];
1130
1131 for (; length > 0; length--)
1132 {
1133 c = *p++ = *q++;
1134 if (c == delimiter && c != 'H' && c != 'h')
1135 q++; /* Skip the doubled delimiter. */
1136 }
1137 }
1138
1139
1140 /* Given actual and expected types in a formatted data transfer, make
1141 sure they agree. If not, an error message is generated. Returns
1142 nonzero if something went wrong. */
1143
1144 static int
require_type(st_parameter_dt * dtp,bt expected,bt actual,const fnode * f)1145 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
1146 {
1147 #define BUFLEN 100
1148 char buffer[BUFLEN];
1149
1150 if (actual == expected)
1151 return 0;
1152
1153 /* Adjust item_count before emitting error message. */
1154 snprintf (buffer, BUFLEN,
1155 "Expected %s for item %d in formatted transfer, got %s",
1156 type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
1157
1158 format_error (dtp, f, buffer);
1159 return 1;
1160 }
1161
1162
1163 static int
require_numeric_type(st_parameter_dt * dtp,bt actual,const fnode * f)1164 require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
1165 {
1166 #define BUFLEN 100
1167 char buffer[BUFLEN];
1168
1169 if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX)
1170 return 0;
1171
1172 /* Adjust item_count before emitting error message. */
1173 snprintf (buffer, BUFLEN,
1174 "Expected numeric type for item %d in formatted transfer, got %s",
1175 dtp->u.p.item_count - 1, type_name (actual));
1176
1177 format_error (dtp, f, buffer);
1178 return 1;
1179 }
1180
1181
1182 /* This function is in the main loop for a formatted data transfer
1183 statement. It would be natural to implement this as a coroutine
1184 with the user program, but C makes that awkward. We loop,
1185 processing format elements. When we actually have to transfer
1186 data instead of just setting flags, we return control to the user
1187 program which calls a function that supplies the address and type
1188 of the next element, then comes back here to process it. */
1189
1190 static void
formatted_transfer_scalar_read(st_parameter_dt * dtp,bt type,void * p,int kind,size_t size)1191 formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1192 size_t size)
1193 {
1194 int pos, bytes_used;
1195 const fnode *f;
1196 format_token t;
1197 int n;
1198 int consume_data_flag;
1199
1200 /* Change a complex data item into a pair of reals. */
1201
1202 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1203 if (type == BT_COMPLEX)
1204 {
1205 type = BT_REAL;
1206 size /= 2;
1207 }
1208
1209 /* If there's an EOR condition, we simulate finalizing the transfer
1210 by doing nothing. */
1211 if (dtp->u.p.eor_condition)
1212 return;
1213
1214 /* Set this flag so that commas in reads cause the read to complete before
1215 the entire field has been read. The next read field will start right after
1216 the comma in the stream. (Set to 0 for character reads). */
1217 dtp->u.p.sf_read_comma =
1218 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
1219
1220 for (;;)
1221 {
1222 /* If reversion has occurred and there is another real data item,
1223 then we have to move to the next record. */
1224 if (dtp->u.p.reversion_flag && n > 0)
1225 {
1226 dtp->u.p.reversion_flag = 0;
1227 next_record (dtp, 0);
1228 }
1229
1230 consume_data_flag = 1;
1231 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1232 break;
1233
1234 f = next_format (dtp);
1235 if (f == NULL)
1236 {
1237 /* No data descriptors left. */
1238 if (unlikely (n > 0))
1239 generate_error (&dtp->common, LIBERROR_FORMAT,
1240 "Insufficient data descriptors in format after reversion");
1241 return;
1242 }
1243
1244 t = f->format;
1245
1246 bytes_used = (int)(dtp->u.p.current_unit->recl
1247 - dtp->u.p.current_unit->bytes_left);
1248
1249 if (is_stream_io(dtp))
1250 bytes_used = 0;
1251
1252 switch (t)
1253 {
1254 case FMT_I:
1255 if (n == 0)
1256 goto need_read_data;
1257 if (require_type (dtp, BT_INTEGER, type, f))
1258 return;
1259 read_decimal (dtp, f, p, kind);
1260 break;
1261
1262 case FMT_B:
1263 if (n == 0)
1264 goto need_read_data;
1265 if (!(compile_options.allow_std & GFC_STD_GNU)
1266 && require_numeric_type (dtp, type, f))
1267 return;
1268 if (!(compile_options.allow_std & GFC_STD_F2008)
1269 && require_type (dtp, BT_INTEGER, type, f))
1270 return;
1271 read_radix (dtp, f, p, kind, 2);
1272 break;
1273
1274 case FMT_O:
1275 if (n == 0)
1276 goto need_read_data;
1277 if (!(compile_options.allow_std & GFC_STD_GNU)
1278 && require_numeric_type (dtp, type, f))
1279 return;
1280 if (!(compile_options.allow_std & GFC_STD_F2008)
1281 && require_type (dtp, BT_INTEGER, type, f))
1282 return;
1283 read_radix (dtp, f, p, kind, 8);
1284 break;
1285
1286 case FMT_Z:
1287 if (n == 0)
1288 goto need_read_data;
1289 if (!(compile_options.allow_std & GFC_STD_GNU)
1290 && require_numeric_type (dtp, type, f))
1291 return;
1292 if (!(compile_options.allow_std & GFC_STD_F2008)
1293 && require_type (dtp, BT_INTEGER, type, f))
1294 return;
1295 read_radix (dtp, f, p, kind, 16);
1296 break;
1297
1298 case FMT_A:
1299 if (n == 0)
1300 goto need_read_data;
1301
1302 /* It is possible to have FMT_A with something not BT_CHARACTER such
1303 as when writing out hollerith strings, so check both type
1304 and kind before calling wide character routines. */
1305 if (type == BT_CHARACTER && kind == 4)
1306 read_a_char4 (dtp, f, p, size);
1307 else
1308 read_a (dtp, f, p, size);
1309 break;
1310
1311 case FMT_L:
1312 if (n == 0)
1313 goto need_read_data;
1314 read_l (dtp, f, p, kind);
1315 break;
1316
1317 case FMT_D:
1318 if (n == 0)
1319 goto need_read_data;
1320 if (require_type (dtp, BT_REAL, type, f))
1321 return;
1322 read_f (dtp, f, p, kind);
1323 break;
1324
1325 case FMT_E:
1326 if (n == 0)
1327 goto need_read_data;
1328 if (require_type (dtp, BT_REAL, type, f))
1329 return;
1330 read_f (dtp, f, p, kind);
1331 break;
1332
1333 case FMT_EN:
1334 if (n == 0)
1335 goto need_read_data;
1336 if (require_type (dtp, BT_REAL, type, f))
1337 return;
1338 read_f (dtp, f, p, kind);
1339 break;
1340
1341 case FMT_ES:
1342 if (n == 0)
1343 goto need_read_data;
1344 if (require_type (dtp, BT_REAL, type, f))
1345 return;
1346 read_f (dtp, f, p, kind);
1347 break;
1348
1349 case FMT_F:
1350 if (n == 0)
1351 goto need_read_data;
1352 if (require_type (dtp, BT_REAL, type, f))
1353 return;
1354 read_f (dtp, f, p, kind);
1355 break;
1356
1357 case FMT_G:
1358 if (n == 0)
1359 goto need_read_data;
1360 switch (type)
1361 {
1362 case BT_INTEGER:
1363 read_decimal (dtp, f, p, kind);
1364 break;
1365 case BT_LOGICAL:
1366 read_l (dtp, f, p, kind);
1367 break;
1368 case BT_CHARACTER:
1369 if (kind == 4)
1370 read_a_char4 (dtp, f, p, size);
1371 else
1372 read_a (dtp, f, p, size);
1373 break;
1374 case BT_REAL:
1375 read_f (dtp, f, p, kind);
1376 break;
1377 default:
1378 internal_error (&dtp->common, "formatted_transfer(): Bad type");
1379 }
1380 break;
1381
1382 case FMT_STRING:
1383 consume_data_flag = 0;
1384 format_error (dtp, f, "Constant string in input format");
1385 return;
1386
1387 /* Format codes that don't transfer data. */
1388 case FMT_X:
1389 case FMT_TR:
1390 consume_data_flag = 0;
1391 dtp->u.p.skips += f->u.n;
1392 pos = bytes_used + dtp->u.p.skips - 1;
1393 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1394 read_x (dtp, f->u.n);
1395 break;
1396
1397 case FMT_TL:
1398 case FMT_T:
1399 consume_data_flag = 0;
1400
1401 if (f->format == FMT_TL)
1402 {
1403 /* Handle the special case when no bytes have been used yet.
1404 Cannot go below zero. */
1405 if (bytes_used == 0)
1406 {
1407 dtp->u.p.pending_spaces -= f->u.n;
1408 dtp->u.p.skips -= f->u.n;
1409 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1410 }
1411
1412 pos = bytes_used - f->u.n;
1413 }
1414 else /* FMT_T */
1415 pos = f->u.n - 1;
1416
1417 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1418 left tab limit. We do not check if the position has gone
1419 beyond the end of record because a subsequent tab could
1420 bring us back again. */
1421 pos = pos < 0 ? 0 : pos;
1422
1423 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1424 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1425 + pos - dtp->u.p.max_pos;
1426 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1427 ? 0 : dtp->u.p.pending_spaces;
1428 if (dtp->u.p.skips == 0)
1429 break;
1430
1431 /* Adjust everything for end-of-record condition */
1432 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1433 {
1434 dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
1435 dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
1436 bytes_used = pos;
1437 if (dtp->u.p.pending_spaces == 0)
1438 dtp->u.p.sf_seen_eor = 0;
1439 }
1440 if (dtp->u.p.skips < 0)
1441 {
1442 if (is_internal_unit (dtp))
1443 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1444 else
1445 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1446 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1447 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1448 }
1449 else
1450 read_x (dtp, dtp->u.p.skips);
1451 break;
1452
1453 case FMT_S:
1454 consume_data_flag = 0;
1455 dtp->u.p.sign_status = SIGN_S;
1456 break;
1457
1458 case FMT_SS:
1459 consume_data_flag = 0;
1460 dtp->u.p.sign_status = SIGN_SS;
1461 break;
1462
1463 case FMT_SP:
1464 consume_data_flag = 0;
1465 dtp->u.p.sign_status = SIGN_SP;
1466 break;
1467
1468 case FMT_BN:
1469 consume_data_flag = 0 ;
1470 dtp->u.p.blank_status = BLANK_NULL;
1471 break;
1472
1473 case FMT_BZ:
1474 consume_data_flag = 0;
1475 dtp->u.p.blank_status = BLANK_ZERO;
1476 break;
1477
1478 case FMT_DC:
1479 consume_data_flag = 0;
1480 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1481 break;
1482
1483 case FMT_DP:
1484 consume_data_flag = 0;
1485 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1486 break;
1487
1488 case FMT_RC:
1489 consume_data_flag = 0;
1490 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1491 break;
1492
1493 case FMT_RD:
1494 consume_data_flag = 0;
1495 dtp->u.p.current_unit->round_status = ROUND_DOWN;
1496 break;
1497
1498 case FMT_RN:
1499 consume_data_flag = 0;
1500 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1501 break;
1502
1503 case FMT_RP:
1504 consume_data_flag = 0;
1505 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1506 break;
1507
1508 case FMT_RU:
1509 consume_data_flag = 0;
1510 dtp->u.p.current_unit->round_status = ROUND_UP;
1511 break;
1512
1513 case FMT_RZ:
1514 consume_data_flag = 0;
1515 dtp->u.p.current_unit->round_status = ROUND_ZERO;
1516 break;
1517
1518 case FMT_P:
1519 consume_data_flag = 0;
1520 dtp->u.p.scale_factor = f->u.k;
1521 break;
1522
1523 case FMT_DOLLAR:
1524 consume_data_flag = 0;
1525 dtp->u.p.seen_dollar = 1;
1526 break;
1527
1528 case FMT_SLASH:
1529 consume_data_flag = 0;
1530 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1531 next_record (dtp, 0);
1532 break;
1533
1534 case FMT_COLON:
1535 /* A colon descriptor causes us to exit this loop (in
1536 particular preventing another / descriptor from being
1537 processed) unless there is another data item to be
1538 transferred. */
1539 consume_data_flag = 0;
1540 if (n == 0)
1541 return;
1542 break;
1543
1544 default:
1545 internal_error (&dtp->common, "Bad format node");
1546 }
1547
1548 /* Adjust the item count and data pointer. */
1549
1550 if ((consume_data_flag > 0) && (n > 0))
1551 {
1552 n--;
1553 p = ((char *) p) + size;
1554 }
1555
1556 dtp->u.p.skips = 0;
1557
1558 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1559 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1560 }
1561
1562 return;
1563
1564 /* Come here when we need a data descriptor but don't have one. We
1565 push the current format node back onto the input, then return and
1566 let the user program call us back with the data. */
1567 need_read_data:
1568 unget_format (dtp, f);
1569 }
1570
1571
1572 static void
formatted_transfer_scalar_write(st_parameter_dt * dtp,bt type,void * p,int kind,size_t size)1573 formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1574 size_t size)
1575 {
1576 int pos, bytes_used;
1577 const fnode *f;
1578 format_token t;
1579 int n;
1580 int consume_data_flag;
1581
1582 /* Change a complex data item into a pair of reals. */
1583
1584 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1585 if (type == BT_COMPLEX)
1586 {
1587 type = BT_REAL;
1588 size /= 2;
1589 }
1590
1591 /* If there's an EOR condition, we simulate finalizing the transfer
1592 by doing nothing. */
1593 if (dtp->u.p.eor_condition)
1594 return;
1595
1596 /* Set this flag so that commas in reads cause the read to complete before
1597 the entire field has been read. The next read field will start right after
1598 the comma in the stream. (Set to 0 for character reads). */
1599 dtp->u.p.sf_read_comma =
1600 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
1601
1602 for (;;)
1603 {
1604 /* If reversion has occurred and there is another real data item,
1605 then we have to move to the next record. */
1606 if (dtp->u.p.reversion_flag && n > 0)
1607 {
1608 dtp->u.p.reversion_flag = 0;
1609 next_record (dtp, 0);
1610 }
1611
1612 consume_data_flag = 1;
1613 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1614 break;
1615
1616 f = next_format (dtp);
1617 if (f == NULL)
1618 {
1619 /* No data descriptors left. */
1620 if (unlikely (n > 0))
1621 generate_error (&dtp->common, LIBERROR_FORMAT,
1622 "Insufficient data descriptors in format after reversion");
1623 return;
1624 }
1625
1626 /* Now discharge T, TR and X movements to the right. This is delayed
1627 until a data producing format to suppress trailing spaces. */
1628
1629 t = f->format;
1630 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
1631 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
1632 || t == FMT_Z || t == FMT_F || t == FMT_E
1633 || t == FMT_EN || t == FMT_ES || t == FMT_G
1634 || t == FMT_L || t == FMT_A || t == FMT_D))
1635 || t == FMT_STRING))
1636 {
1637 if (dtp->u.p.skips > 0)
1638 {
1639 int tmp;
1640 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1641 tmp = (int)(dtp->u.p.current_unit->recl
1642 - dtp->u.p.current_unit->bytes_left);
1643 dtp->u.p.max_pos =
1644 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
1645 dtp->u.p.skips = 0;
1646 }
1647 if (dtp->u.p.skips < 0)
1648 {
1649 if (is_internal_unit (dtp))
1650 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1651 else
1652 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1653 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1654 }
1655 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1656 }
1657
1658 bytes_used = (int)(dtp->u.p.current_unit->recl
1659 - dtp->u.p.current_unit->bytes_left);
1660
1661 if (is_stream_io(dtp))
1662 bytes_used = 0;
1663
1664 switch (t)
1665 {
1666 case FMT_I:
1667 if (n == 0)
1668 goto need_data;
1669 if (require_type (dtp, BT_INTEGER, type, f))
1670 return;
1671 write_i (dtp, f, p, kind);
1672 break;
1673
1674 case FMT_B:
1675 if (n == 0)
1676 goto need_data;
1677 if (!(compile_options.allow_std & GFC_STD_GNU)
1678 && require_numeric_type (dtp, type, f))
1679 return;
1680 if (!(compile_options.allow_std & GFC_STD_F2008)
1681 && require_type (dtp, BT_INTEGER, type, f))
1682 return;
1683 write_b (dtp, f, p, kind);
1684 break;
1685
1686 case FMT_O:
1687 if (n == 0)
1688 goto need_data;
1689 if (!(compile_options.allow_std & GFC_STD_GNU)
1690 && require_numeric_type (dtp, type, f))
1691 return;
1692 if (!(compile_options.allow_std & GFC_STD_F2008)
1693 && require_type (dtp, BT_INTEGER, type, f))
1694 return;
1695 write_o (dtp, f, p, kind);
1696 break;
1697
1698 case FMT_Z:
1699 if (n == 0)
1700 goto need_data;
1701 if (!(compile_options.allow_std & GFC_STD_GNU)
1702 && require_numeric_type (dtp, type, f))
1703 return;
1704 if (!(compile_options.allow_std & GFC_STD_F2008)
1705 && require_type (dtp, BT_INTEGER, type, f))
1706 return;
1707 write_z (dtp, f, p, kind);
1708 break;
1709
1710 case FMT_A:
1711 if (n == 0)
1712 goto need_data;
1713
1714 /* It is possible to have FMT_A with something not BT_CHARACTER such
1715 as when writing out hollerith strings, so check both type
1716 and kind before calling wide character routines. */
1717 if (type == BT_CHARACTER && kind == 4)
1718 write_a_char4 (dtp, f, p, size);
1719 else
1720 write_a (dtp, f, p, size);
1721 break;
1722
1723 case FMT_L:
1724 if (n == 0)
1725 goto need_data;
1726 write_l (dtp, f, p, kind);
1727 break;
1728
1729 case FMT_D:
1730 if (n == 0)
1731 goto need_data;
1732 if (require_type (dtp, BT_REAL, type, f))
1733 return;
1734 write_d (dtp, f, p, kind);
1735 break;
1736
1737 case FMT_E:
1738 if (n == 0)
1739 goto need_data;
1740 if (require_type (dtp, BT_REAL, type, f))
1741 return;
1742 write_e (dtp, f, p, kind);
1743 break;
1744
1745 case FMT_EN:
1746 if (n == 0)
1747 goto need_data;
1748 if (require_type (dtp, BT_REAL, type, f))
1749 return;
1750 write_en (dtp, f, p, kind);
1751 break;
1752
1753 case FMT_ES:
1754 if (n == 0)
1755 goto need_data;
1756 if (require_type (dtp, BT_REAL, type, f))
1757 return;
1758 write_es (dtp, f, p, kind);
1759 break;
1760
1761 case FMT_F:
1762 if (n == 0)
1763 goto need_data;
1764 if (require_type (dtp, BT_REAL, type, f))
1765 return;
1766 write_f (dtp, f, p, kind);
1767 break;
1768
1769 case FMT_G:
1770 if (n == 0)
1771 goto need_data;
1772 switch (type)
1773 {
1774 case BT_INTEGER:
1775 write_i (dtp, f, p, kind);
1776 break;
1777 case BT_LOGICAL:
1778 write_l (dtp, f, p, kind);
1779 break;
1780 case BT_CHARACTER:
1781 if (kind == 4)
1782 write_a_char4 (dtp, f, p, size);
1783 else
1784 write_a (dtp, f, p, size);
1785 break;
1786 case BT_REAL:
1787 if (f->u.real.w == 0)
1788 write_real_g0 (dtp, p, kind, f->u.real.d);
1789 else
1790 write_d (dtp, f, p, kind);
1791 break;
1792 default:
1793 internal_error (&dtp->common,
1794 "formatted_transfer(): Bad type");
1795 }
1796 break;
1797
1798 case FMT_STRING:
1799 consume_data_flag = 0;
1800 write_constant_string (dtp, f);
1801 break;
1802
1803 /* Format codes that don't transfer data. */
1804 case FMT_X:
1805 case FMT_TR:
1806 consume_data_flag = 0;
1807
1808 dtp->u.p.skips += f->u.n;
1809 pos = bytes_used + dtp->u.p.skips - 1;
1810 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1811 /* Writes occur just before the switch on f->format, above, so
1812 that trailing blanks are suppressed, unless we are doing a
1813 non-advancing write in which case we want to output the blanks
1814 now. */
1815 if (dtp->u.p.advance_status == ADVANCE_NO)
1816 {
1817 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1818 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1819 }
1820 break;
1821
1822 case FMT_TL:
1823 case FMT_T:
1824 consume_data_flag = 0;
1825
1826 if (f->format == FMT_TL)
1827 {
1828
1829 /* Handle the special case when no bytes have been used yet.
1830 Cannot go below zero. */
1831 if (bytes_used == 0)
1832 {
1833 dtp->u.p.pending_spaces -= f->u.n;
1834 dtp->u.p.skips -= f->u.n;
1835 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1836 }
1837
1838 pos = bytes_used - f->u.n;
1839 }
1840 else /* FMT_T */
1841 pos = f->u.n - dtp->u.p.pending_spaces - 1;
1842
1843 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1844 left tab limit. We do not check if the position has gone
1845 beyond the end of record because a subsequent tab could
1846 bring us back again. */
1847 pos = pos < 0 ? 0 : pos;
1848
1849 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1850 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1851 + pos - dtp->u.p.max_pos;
1852 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1853 ? 0 : dtp->u.p.pending_spaces;
1854 break;
1855
1856 case FMT_S:
1857 consume_data_flag = 0;
1858 dtp->u.p.sign_status = SIGN_S;
1859 break;
1860
1861 case FMT_SS:
1862 consume_data_flag = 0;
1863 dtp->u.p.sign_status = SIGN_SS;
1864 break;
1865
1866 case FMT_SP:
1867 consume_data_flag = 0;
1868 dtp->u.p.sign_status = SIGN_SP;
1869 break;
1870
1871 case FMT_BN:
1872 consume_data_flag = 0 ;
1873 dtp->u.p.blank_status = BLANK_NULL;
1874 break;
1875
1876 case FMT_BZ:
1877 consume_data_flag = 0;
1878 dtp->u.p.blank_status = BLANK_ZERO;
1879 break;
1880
1881 case FMT_DC:
1882 consume_data_flag = 0;
1883 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1884 break;
1885
1886 case FMT_DP:
1887 consume_data_flag = 0;
1888 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1889 break;
1890
1891 case FMT_RC:
1892 consume_data_flag = 0;
1893 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1894 break;
1895
1896 case FMT_RD:
1897 consume_data_flag = 0;
1898 dtp->u.p.current_unit->round_status = ROUND_DOWN;
1899 break;
1900
1901 case FMT_RN:
1902 consume_data_flag = 0;
1903 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1904 break;
1905
1906 case FMT_RP:
1907 consume_data_flag = 0;
1908 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1909 break;
1910
1911 case FMT_RU:
1912 consume_data_flag = 0;
1913 dtp->u.p.current_unit->round_status = ROUND_UP;
1914 break;
1915
1916 case FMT_RZ:
1917 consume_data_flag = 0;
1918 dtp->u.p.current_unit->round_status = ROUND_ZERO;
1919 break;
1920
1921 case FMT_P:
1922 consume_data_flag = 0;
1923 dtp->u.p.scale_factor = f->u.k;
1924 break;
1925
1926 case FMT_DOLLAR:
1927 consume_data_flag = 0;
1928 dtp->u.p.seen_dollar = 1;
1929 break;
1930
1931 case FMT_SLASH:
1932 consume_data_flag = 0;
1933 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1934 next_record (dtp, 0);
1935 break;
1936
1937 case FMT_COLON:
1938 /* A colon descriptor causes us to exit this loop (in
1939 particular preventing another / descriptor from being
1940 processed) unless there is another data item to be
1941 transferred. */
1942 consume_data_flag = 0;
1943 if (n == 0)
1944 return;
1945 break;
1946
1947 default:
1948 internal_error (&dtp->common, "Bad format node");
1949 }
1950
1951 /* Adjust the item count and data pointer. */
1952
1953 if ((consume_data_flag > 0) && (n > 0))
1954 {
1955 n--;
1956 p = ((char *) p) + size;
1957 }
1958
1959 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1960 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1961 }
1962
1963 return;
1964
1965 /* Come here when we need a data descriptor but don't have one. We
1966 push the current format node back onto the input, then return and
1967 let the user program call us back with the data. */
1968 need_data:
1969 unget_format (dtp, f);
1970 }
1971
1972 /* This function is first called from data_init_transfer to initiate the loop
1973 over each item in the format, transferring data as required. Subsequent
1974 calls to this function occur for each data item foound in the READ/WRITE
1975 statement. The item_count is incremented for each call. Since the first
1976 call is from data_transfer_init, the item_count is always one greater than
1977 the actual count number of the item being transferred. */
1978
1979 static void
formatted_transfer(st_parameter_dt * dtp,bt type,void * p,int kind,size_t size,size_t nelems)1980 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1981 size_t size, size_t nelems)
1982 {
1983 size_t elem;
1984 char *tmp;
1985
1986 tmp = (char *) p;
1987 size_t stride = type == BT_CHARACTER ?
1988 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1989 if (dtp->u.p.mode == READING)
1990 {
1991 /* Big loop over all the elements. */
1992 for (elem = 0; elem < nelems; elem++)
1993 {
1994 dtp->u.p.item_count++;
1995 formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
1996 }
1997 }
1998 else
1999 {
2000 /* Big loop over all the elements. */
2001 for (elem = 0; elem < nelems; elem++)
2002 {
2003 dtp->u.p.item_count++;
2004 formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
2005 }
2006 }
2007 }
2008
2009
2010 /* Data transfer entry points. The type of the data entity is
2011 implicit in the subroutine call. This prevents us from having to
2012 share a common enum with the compiler. */
2013
2014 void
transfer_integer(st_parameter_dt * dtp,void * p,int kind)2015 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
2016 {
2017 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2018 return;
2019 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
2020 }
2021
2022 void
transfer_integer_write(st_parameter_dt * dtp,void * p,int kind)2023 transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
2024 {
2025 transfer_integer (dtp, p, kind);
2026 }
2027
2028 void
transfer_real(st_parameter_dt * dtp,void * p,int kind)2029 transfer_real (st_parameter_dt *dtp, void *p, int kind)
2030 {
2031 size_t size;
2032 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2033 return;
2034 size = size_from_real_kind (kind);
2035 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
2036 }
2037
2038 void
transfer_real_write(st_parameter_dt * dtp,void * p,int kind)2039 transfer_real_write (st_parameter_dt *dtp, void *p, int kind)
2040 {
2041 transfer_real (dtp, p, kind);
2042 }
2043
2044 void
transfer_logical(st_parameter_dt * dtp,void * p,int kind)2045 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
2046 {
2047 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2048 return;
2049 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
2050 }
2051
2052 void
transfer_logical_write(st_parameter_dt * dtp,void * p,int kind)2053 transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
2054 {
2055 transfer_logical (dtp, p, kind);
2056 }
2057
2058 void
transfer_character(st_parameter_dt * dtp,void * p,int len)2059 transfer_character (st_parameter_dt *dtp, void *p, int len)
2060 {
2061 static char *empty_string[0];
2062
2063 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2064 return;
2065
2066 /* Strings of zero length can have p == NULL, which confuses the
2067 transfer routines into thinking we need more data elements. To avoid
2068 this, we give them a nice pointer. */
2069 if (len == 0 && p == NULL)
2070 p = empty_string;
2071
2072 /* Set kind here to 1. */
2073 dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
2074 }
2075
2076 void
transfer_character_write(st_parameter_dt * dtp,void * p,int len)2077 transfer_character_write (st_parameter_dt *dtp, void *p, int len)
2078 {
2079 transfer_character (dtp, p, len);
2080 }
2081
2082 void
transfer_character_wide(st_parameter_dt * dtp,void * p,int len,int kind)2083 transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
2084 {
2085 static char *empty_string[0];
2086
2087 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2088 return;
2089
2090 /* Strings of zero length can have p == NULL, which confuses the
2091 transfer routines into thinking we need more data elements. To avoid
2092 this, we give them a nice pointer. */
2093 if (len == 0 && p == NULL)
2094 p = empty_string;
2095
2096 /* Here we pass the actual kind value. */
2097 dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
2098 }
2099
2100 void
transfer_character_wide_write(st_parameter_dt * dtp,void * p,int len,int kind)2101 transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
2102 {
2103 transfer_character_wide (dtp, p, len, kind);
2104 }
2105
2106 void
transfer_complex(st_parameter_dt * dtp,void * p,int kind)2107 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
2108 {
2109 size_t size;
2110 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2111 return;
2112 size = size_from_complex_kind (kind);
2113 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
2114 }
2115
2116 void
transfer_complex_write(st_parameter_dt * dtp,void * p,int kind)2117 transfer_complex_write (st_parameter_dt *dtp, void *p, int kind)
2118 {
2119 transfer_complex (dtp, p, kind);
2120 }
2121
2122 void
transfer_array(st_parameter_dt * dtp,gfc_array_char * desc,int kind,gfc_charlen_type charlen)2123 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2124 gfc_charlen_type charlen)
2125 {
2126 index_type count[GFC_MAX_DIMENSIONS];
2127 index_type extent[GFC_MAX_DIMENSIONS];
2128 index_type stride[GFC_MAX_DIMENSIONS];
2129 index_type stride0, rank, size, n;
2130 size_t tsize;
2131 char *data;
2132 bt iotype;
2133
2134 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2135 return;
2136
2137 iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
2138 size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
2139
2140 rank = GFC_DESCRIPTOR_RANK (desc);
2141 for (n = 0; n < rank; n++)
2142 {
2143 count[n] = 0;
2144 stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
2145 extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
2146
2147 /* If the extent of even one dimension is zero, then the entire
2148 array section contains zero elements, so we return after writing
2149 a zero array record. */
2150 if (extent[n] <= 0)
2151 {
2152 data = NULL;
2153 tsize = 0;
2154 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2155 return;
2156 }
2157 }
2158
2159 stride0 = stride[0];
2160
2161 /* If the innermost dimension has a stride of 1, we can do the transfer
2162 in contiguous chunks. */
2163 if (stride0 == size)
2164 tsize = extent[0];
2165 else
2166 tsize = 1;
2167
2168 data = GFC_DESCRIPTOR_DATA (desc);
2169
2170 while (data)
2171 {
2172 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2173 data += stride0 * tsize;
2174 count[0] += tsize;
2175 n = 0;
2176 while (count[n] == extent[n])
2177 {
2178 count[n] = 0;
2179 data -= stride[n] * extent[n];
2180 n++;
2181 if (n == rank)
2182 {
2183 data = NULL;
2184 break;
2185 }
2186 else
2187 {
2188 count[n]++;
2189 data += stride[n];
2190 }
2191 }
2192 }
2193 }
2194
2195 void
transfer_array_write(st_parameter_dt * dtp,gfc_array_char * desc,int kind,gfc_charlen_type charlen)2196 transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2197 gfc_charlen_type charlen)
2198 {
2199 transfer_array (dtp, desc, kind, charlen);
2200 }
2201
2202 /* Preposition a sequential unformatted file while reading. */
2203
2204 static void
us_read(st_parameter_dt * dtp,int continued)2205 us_read (st_parameter_dt *dtp, int continued)
2206 {
2207 ssize_t n, nr;
2208 GFC_INTEGER_4 i4;
2209 GFC_INTEGER_8 i8;
2210 gfc_offset i;
2211
2212 if (compile_options.record_marker == 0)
2213 n = sizeof (GFC_INTEGER_4);
2214 else
2215 n = compile_options.record_marker;
2216
2217 nr = sread (dtp->u.p.current_unit->s, &i, n);
2218 if (unlikely (nr < 0))
2219 {
2220 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2221 return;
2222 }
2223 else if (nr == 0)
2224 {
2225 hit_eof (dtp);
2226 return; /* end of file */
2227 }
2228 else if (unlikely (n != nr))
2229 {
2230 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2231 return;
2232 }
2233
2234 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2235 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
2236 {
2237 switch (nr)
2238 {
2239 case sizeof(GFC_INTEGER_4):
2240 memcpy (&i4, &i, sizeof (i4));
2241 i = i4;
2242 break;
2243
2244 case sizeof(GFC_INTEGER_8):
2245 memcpy (&i8, &i, sizeof (i8));
2246 i = i8;
2247 break;
2248
2249 default:
2250 runtime_error ("Illegal value for record marker");
2251 break;
2252 }
2253 }
2254 else
2255 {
2256 uint32_t u32;
2257 uint64_t u64;
2258 switch (nr)
2259 {
2260 case sizeof(GFC_INTEGER_4):
2261 memcpy (&u32, &i, sizeof (u32));
2262 u32 = __builtin_bswap32 (u32);
2263 memcpy (&i4, &u32, sizeof (i4));
2264 i = i4;
2265 break;
2266
2267 case sizeof(GFC_INTEGER_8):
2268 memcpy (&u64, &i, sizeof (u64));
2269 u64 = __builtin_bswap64 (u64);
2270 memcpy (&i8, &u64, sizeof (i8));
2271 i = i8;
2272 break;
2273
2274 default:
2275 runtime_error ("Illegal value for record marker");
2276 break;
2277 }
2278 }
2279
2280 if (i >= 0)
2281 {
2282 dtp->u.p.current_unit->bytes_left_subrecord = i;
2283 dtp->u.p.current_unit->continued = 0;
2284 }
2285 else
2286 {
2287 dtp->u.p.current_unit->bytes_left_subrecord = -i;
2288 dtp->u.p.current_unit->continued = 1;
2289 }
2290
2291 if (! continued)
2292 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2293 }
2294
2295
2296 /* Preposition a sequential unformatted file while writing. This
2297 amount to writing a bogus length that will be filled in later. */
2298
2299 static void
us_write(st_parameter_dt * dtp,int continued)2300 us_write (st_parameter_dt *dtp, int continued)
2301 {
2302 ssize_t nbytes;
2303 gfc_offset dummy;
2304
2305 dummy = 0;
2306
2307 if (compile_options.record_marker == 0)
2308 nbytes = sizeof (GFC_INTEGER_4);
2309 else
2310 nbytes = compile_options.record_marker ;
2311
2312 if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
2313 generate_error (&dtp->common, LIBERROR_OS, NULL);
2314
2315 /* For sequential unformatted, if RECL= was not specified in the OPEN
2316 we write until we have more bytes than can fit in the subrecord
2317 markers, then we write a new subrecord. */
2318
2319 dtp->u.p.current_unit->bytes_left_subrecord =
2320 dtp->u.p.current_unit->recl_subrecord;
2321 dtp->u.p.current_unit->continued = continued;
2322 }
2323
2324
2325 /* Position to the next record prior to transfer. We are assumed to
2326 be before the next record. We also calculate the bytes in the next
2327 record. */
2328
2329 static void
pre_position(st_parameter_dt * dtp)2330 pre_position (st_parameter_dt *dtp)
2331 {
2332 if (dtp->u.p.current_unit->current_record)
2333 return; /* Already positioned. */
2334
2335 switch (current_mode (dtp))
2336 {
2337 case FORMATTED_STREAM:
2338 case UNFORMATTED_STREAM:
2339 /* There are no records with stream I/O. If the position was specified
2340 data_transfer_init has already positioned the file. If no position
2341 was specified, we continue from where we last left off. I.e.
2342 there is nothing to do here. */
2343 break;
2344
2345 case UNFORMATTED_SEQUENTIAL:
2346 if (dtp->u.p.mode == READING)
2347 us_read (dtp, 0);
2348 else
2349 us_write (dtp, 0);
2350
2351 break;
2352
2353 case FORMATTED_SEQUENTIAL:
2354 case FORMATTED_DIRECT:
2355 case UNFORMATTED_DIRECT:
2356 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2357 break;
2358 }
2359
2360 dtp->u.p.current_unit->current_record = 1;
2361 }
2362
2363
2364 /* Initialize things for a data transfer. This code is common for
2365 both reading and writing. */
2366
2367 static void
data_transfer_init(st_parameter_dt * dtp,int read_flag)2368 data_transfer_init (st_parameter_dt *dtp, int read_flag)
2369 {
2370 unit_flags u_flags; /* Used for creating a unit if needed. */
2371 GFC_INTEGER_4 cf = dtp->common.flags;
2372 namelist_info *ionml;
2373
2374 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
2375
2376 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2377
2378 dtp->u.p.ionml = ionml;
2379 dtp->u.p.mode = read_flag ? READING : WRITING;
2380
2381 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2382 return;
2383
2384 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2385 dtp->u.p.size_used = 0; /* Initialize the count. */
2386
2387 dtp->u.p.current_unit = get_unit (dtp, 1);
2388 if (dtp->u.p.current_unit->s == NULL)
2389 { /* Open the unit with some default flags. */
2390 st_parameter_open opp;
2391 unit_convert conv;
2392
2393 if (dtp->common.unit < 0)
2394 {
2395 close_unit (dtp->u.p.current_unit);
2396 dtp->u.p.current_unit = NULL;
2397 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2398 "Bad unit number in statement");
2399 return;
2400 }
2401 memset (&u_flags, '\0', sizeof (u_flags));
2402 u_flags.access = ACCESS_SEQUENTIAL;
2403 u_flags.action = ACTION_READWRITE;
2404
2405 /* Is it unformatted? */
2406 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
2407 | IOPARM_DT_IONML_SET)))
2408 u_flags.form = FORM_UNFORMATTED;
2409 else
2410 u_flags.form = FORM_UNSPECIFIED;
2411
2412 u_flags.delim = DELIM_UNSPECIFIED;
2413 u_flags.blank = BLANK_UNSPECIFIED;
2414 u_flags.pad = PAD_UNSPECIFIED;
2415 u_flags.decimal = DECIMAL_UNSPECIFIED;
2416 u_flags.encoding = ENCODING_UNSPECIFIED;
2417 u_flags.async = ASYNC_UNSPECIFIED;
2418 u_flags.round = ROUND_UNSPECIFIED;
2419 u_flags.sign = SIGN_UNSPECIFIED;
2420
2421 u_flags.status = STATUS_UNKNOWN;
2422
2423 conv = get_unformatted_convert (dtp->common.unit);
2424
2425 if (conv == GFC_CONVERT_NONE)
2426 conv = compile_options.convert;
2427
2428 /* We use big_endian, which is 0 on little-endian machines
2429 and 1 on big-endian machines. */
2430 switch (conv)
2431 {
2432 case GFC_CONVERT_NATIVE:
2433 case GFC_CONVERT_SWAP:
2434 break;
2435
2436 case GFC_CONVERT_BIG:
2437 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
2438 break;
2439
2440 case GFC_CONVERT_LITTLE:
2441 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
2442 break;
2443
2444 default:
2445 internal_error (&opp.common, "Illegal value for CONVERT");
2446 break;
2447 }
2448
2449 u_flags.convert = conv;
2450
2451 opp.common = dtp->common;
2452 opp.common.flags &= IOPARM_COMMON_MASK;
2453 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
2454 dtp->common.flags &= ~IOPARM_COMMON_MASK;
2455 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
2456 if (dtp->u.p.current_unit == NULL)
2457 return;
2458 }
2459
2460 /* Check the action. */
2461
2462 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
2463 {
2464 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2465 "Cannot read from file opened for WRITE");
2466 return;
2467 }
2468
2469 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
2470 {
2471 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2472 "Cannot write to file opened for READ");
2473 return;
2474 }
2475
2476 dtp->u.p.first_item = 1;
2477
2478 /* Check the format. */
2479
2480 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2481 parse_format (dtp);
2482
2483 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
2484 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2485 != 0)
2486 {
2487 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2488 "Format present for UNFORMATTED data transfer");
2489 return;
2490 }
2491
2492 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
2493 {
2494 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2495 {
2496 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2497 "A format cannot be specified with a namelist");
2498 return;
2499 }
2500 }
2501 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
2502 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
2503 {
2504 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2505 "Missing format for FORMATTED data transfer");
2506 return;
2507 }
2508
2509 if (is_internal_unit (dtp)
2510 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2511 {
2512 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2513 "Internal file cannot be accessed by UNFORMATTED "
2514 "data transfer");
2515 return;
2516 }
2517
2518 /* Check the record or position number. */
2519
2520 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
2521 && (cf & IOPARM_DT_HAS_REC) == 0)
2522 {
2523 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2524 "Direct access data transfer requires record number");
2525 return;
2526 }
2527
2528 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2529 {
2530 if ((cf & IOPARM_DT_HAS_REC) != 0)
2531 {
2532 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2533 "Record number not allowed for sequential access "
2534 "data transfer");
2535 return;
2536 }
2537
2538 if (compile_options.warn_std &&
2539 dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
2540 {
2541 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2542 "Sequential READ or WRITE not allowed after "
2543 "EOF marker, possibly use REWIND or BACKSPACE");
2544 return;
2545 }
2546
2547 }
2548 /* Process the ADVANCE option. */
2549
2550 dtp->u.p.advance_status
2551 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
2552 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
2553 "Bad ADVANCE parameter in data transfer statement");
2554
2555 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
2556 {
2557 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2558 {
2559 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2560 "ADVANCE specification conflicts with sequential "
2561 "access");
2562 return;
2563 }
2564
2565 if (is_internal_unit (dtp))
2566 {
2567 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2568 "ADVANCE specification conflicts with internal file");
2569 return;
2570 }
2571
2572 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2573 != IOPARM_DT_HAS_FORMAT)
2574 {
2575 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2576 "ADVANCE specification requires an explicit format");
2577 return;
2578 }
2579 }
2580
2581 if (read_flag)
2582 {
2583 dtp->u.p.current_unit->previous_nonadvancing_write = 0;
2584
2585 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
2586 {
2587 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2588 "EOR specification requires an ADVANCE specification "
2589 "of NO");
2590 return;
2591 }
2592
2593 if ((cf & IOPARM_DT_HAS_SIZE) != 0
2594 && dtp->u.p.advance_status != ADVANCE_NO)
2595 {
2596 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2597 "SIZE specification requires an ADVANCE "
2598 "specification of NO");
2599 return;
2600 }
2601 }
2602 else
2603 { /* Write constraints. */
2604 if ((cf & IOPARM_END) != 0)
2605 {
2606 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2607 "END specification cannot appear in a write "
2608 "statement");
2609 return;
2610 }
2611
2612 if ((cf & IOPARM_EOR) != 0)
2613 {
2614 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2615 "EOR specification cannot appear in a write "
2616 "statement");
2617 return;
2618 }
2619
2620 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2621 {
2622 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2623 "SIZE specification cannot appear in a write "
2624 "statement");
2625 return;
2626 }
2627 }
2628
2629 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
2630 dtp->u.p.advance_status = ADVANCE_YES;
2631
2632 /* Check the decimal mode. */
2633 dtp->u.p.current_unit->decimal_status
2634 = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
2635 find_option (&dtp->common, dtp->decimal, dtp->decimal_len,
2636 decimal_opt, "Bad DECIMAL parameter in data transfer "
2637 "statement");
2638
2639 if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
2640 dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
2641
2642 /* Check the round mode. */
2643 dtp->u.p.current_unit->round_status
2644 = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
2645 find_option (&dtp->common, dtp->round, dtp->round_len,
2646 round_opt, "Bad ROUND parameter in data transfer "
2647 "statement");
2648
2649 if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
2650 dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
2651
2652 /* Check the sign mode. */
2653 dtp->u.p.sign_status
2654 = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
2655 find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
2656 "Bad SIGN parameter in data transfer statement");
2657
2658 if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
2659 dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
2660
2661 /* Check the blank mode. */
2662 dtp->u.p.blank_status
2663 = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
2664 find_option (&dtp->common, dtp->blank, dtp->blank_len,
2665 blank_opt,
2666 "Bad BLANK parameter in data transfer statement");
2667
2668 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
2669 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
2670
2671 /* Check the delim mode. */
2672 dtp->u.p.current_unit->delim_status
2673 = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
2674 find_option (&dtp->common, dtp->delim, dtp->delim_len,
2675 delim_opt, "Bad DELIM parameter in data transfer statement");
2676
2677 if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
2678 {
2679 if (ionml && dtp->u.p.current_unit->flags.delim == DELIM_UNSPECIFIED)
2680 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
2681 else
2682 dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
2683 }
2684
2685 /* Check the pad mode. */
2686 dtp->u.p.current_unit->pad_status
2687 = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
2688 find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
2689 "Bad PAD parameter in data transfer statement");
2690
2691 if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
2692 dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
2693
2694 /* Check to see if we might be reading what we wrote before */
2695
2696 if (dtp->u.p.mode != dtp->u.p.current_unit->mode
2697 && !is_internal_unit (dtp))
2698 {
2699 int pos = fbuf_reset (dtp->u.p.current_unit);
2700 if (pos != 0)
2701 sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
2702 sflush(dtp->u.p.current_unit->s);
2703 }
2704
2705 /* Check the POS= specifier: that it is in range and that it is used with a
2706 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2707
2708 if (((cf & IOPARM_DT_HAS_POS) != 0))
2709 {
2710 if (is_stream_io (dtp))
2711 {
2712
2713 if (dtp->pos <= 0)
2714 {
2715 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2716 "POS=specifier must be positive");
2717 return;
2718 }
2719
2720 if (dtp->pos >= dtp->u.p.current_unit->maxrec)
2721 {
2722 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2723 "POS=specifier too large");
2724 return;
2725 }
2726
2727 dtp->rec = dtp->pos;
2728
2729 if (dtp->u.p.mode == READING)
2730 {
2731 /* Reset the endfile flag; if we hit EOF during reading
2732 we'll set the flag and generate an error at that point
2733 rather than worrying about it here. */
2734 dtp->u.p.current_unit->endfile = NO_ENDFILE;
2735 }
2736
2737 if (dtp->pos != dtp->u.p.current_unit->strm_pos)
2738 {
2739 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
2740 if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
2741 {
2742 generate_error (&dtp->common, LIBERROR_OS, NULL);
2743 return;
2744 }
2745 dtp->u.p.current_unit->strm_pos = dtp->pos;
2746 }
2747 }
2748 else
2749 {
2750 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2751 "POS=specifier not allowed, "
2752 "Try OPEN with ACCESS='stream'");
2753 return;
2754 }
2755 }
2756
2757
2758 /* Sanity checks on the record number. */
2759 if ((cf & IOPARM_DT_HAS_REC) != 0)
2760 {
2761 if (dtp->rec <= 0)
2762 {
2763 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2764 "Record number must be positive");
2765 return;
2766 }
2767
2768 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
2769 {
2770 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2771 "Record number too large");
2772 return;
2773 }
2774
2775 /* Make sure format buffer is reset. */
2776 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2777 fbuf_reset (dtp->u.p.current_unit);
2778
2779
2780 /* Check whether the record exists to be read. Only
2781 a partial record needs to exist. */
2782
2783 if (dtp->u.p.mode == READING && (dtp->rec - 1)
2784 * dtp->u.p.current_unit->recl >= ssize (dtp->u.p.current_unit->s))
2785 {
2786 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2787 "Non-existing record number");
2788 return;
2789 }
2790
2791 /* Position the file. */
2792 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
2793 * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
2794 {
2795 generate_error (&dtp->common, LIBERROR_OS, NULL);
2796 return;
2797 }
2798
2799 /* TODO: This is required to maintain compatibility between
2800 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2801
2802 if (is_stream_io (dtp))
2803 dtp->u.p.current_unit->strm_pos = dtp->rec;
2804
2805 /* TODO: Un-comment this code when ABI changes from 4.3.
2806 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2807 {
2808 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2809 "Record number not allowed for stream access "
2810 "data transfer");
2811 return;
2812 } */
2813 }
2814
2815 /* Bugware for badly written mixed C-Fortran I/O. */
2816 if (!is_internal_unit (dtp))
2817 flush_if_preconnected(dtp->u.p.current_unit->s);
2818
2819 dtp->u.p.current_unit->mode = dtp->u.p.mode;
2820
2821 /* Set the maximum position reached from the previous I/O operation. This
2822 could be greater than zero from a previous non-advancing write. */
2823 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
2824
2825 pre_position (dtp);
2826
2827
2828 /* Set up the subroutine that will handle the transfers. */
2829
2830 if (read_flag)
2831 {
2832 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2833 dtp->u.p.transfer = unformatted_read;
2834 else
2835 {
2836 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2837 {
2838 dtp->u.p.last_char = EOF - 1;
2839 dtp->u.p.transfer = list_formatted_read;
2840 }
2841 else
2842 dtp->u.p.transfer = formatted_transfer;
2843 }
2844 }
2845 else
2846 {
2847 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2848 dtp->u.p.transfer = unformatted_write;
2849 else
2850 {
2851 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2852 dtp->u.p.transfer = list_formatted_write;
2853 else
2854 dtp->u.p.transfer = formatted_transfer;
2855 }
2856 }
2857
2858 /* Make sure that we don't do a read after a nonadvancing write. */
2859
2860 if (read_flag)
2861 {
2862 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
2863 {
2864 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2865 "Cannot READ after a nonadvancing WRITE");
2866 return;
2867 }
2868 }
2869 else
2870 {
2871 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2872 dtp->u.p.current_unit->read_bad = 1;
2873 }
2874
2875 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2876 {
2877 #ifdef HAVE_USELOCALE
2878 dtp->u.p.old_locale = uselocale (c_locale);
2879 #else
2880 __gthread_mutex_lock (&old_locale_lock);
2881 if (!old_locale_ctr++)
2882 {
2883 old_locale = setlocale (LC_NUMERIC, NULL);
2884 setlocale (LC_NUMERIC, "C");
2885 }
2886 __gthread_mutex_unlock (&old_locale_lock);
2887 #endif
2888 /* Start the data transfer if we are doing a formatted transfer. */
2889 if ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0
2890 && dtp->u.p.ionml == NULL)
2891 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2892 }
2893 }
2894
2895
2896 /* Initialize an array_loop_spec given the array descriptor. The function
2897 returns the index of the last element of the array, and also returns
2898 starting record, where the first I/O goes to (necessary in case of
2899 negative strides). */
2900
2901 gfc_offset
init_loop_spec(gfc_array_char * desc,array_loop_spec * ls,gfc_offset * start_record)2902 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
2903 gfc_offset *start_record)
2904 {
2905 int rank = GFC_DESCRIPTOR_RANK(desc);
2906 int i;
2907 gfc_offset index;
2908 int empty;
2909
2910 empty = 0;
2911 index = 1;
2912 *start_record = 0;
2913
2914 for (i=0; i<rank; i++)
2915 {
2916 ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i);
2917 ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
2918 ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
2919 ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
2920 empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
2921 < GFC_DESCRIPTOR_LBOUND(desc,i));
2922
2923 if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
2924 {
2925 index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2926 * GFC_DESCRIPTOR_STRIDE(desc,i);
2927 }
2928 else
2929 {
2930 index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2931 * GFC_DESCRIPTOR_STRIDE(desc,i);
2932 *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2933 * GFC_DESCRIPTOR_STRIDE(desc,i);
2934 }
2935 }
2936
2937 if (empty)
2938 return 0;
2939 else
2940 return index;
2941 }
2942
2943 /* Determine the index to the next record in an internal unit array by
2944 by incrementing through the array_loop_spec. */
2945
2946 gfc_offset
next_array_record(st_parameter_dt * dtp,array_loop_spec * ls,int * finished)2947 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
2948 {
2949 int i, carry;
2950 gfc_offset index;
2951
2952 carry = 1;
2953 index = 0;
2954
2955 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2956 {
2957 if (carry)
2958 {
2959 ls[i].idx++;
2960 if (ls[i].idx > ls[i].end)
2961 {
2962 ls[i].idx = ls[i].start;
2963 carry = 1;
2964 }
2965 else
2966 carry = 0;
2967 }
2968 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2969 }
2970
2971 *finished = carry;
2972
2973 return index;
2974 }
2975
2976
2977
2978 /* Skip to the end of the current record, taking care of an optional
2979 record marker of size bytes. If the file is not seekable, we
2980 read chunks of size MAX_READ until we get to the right
2981 position. */
2982
2983 static void
skip_record(st_parameter_dt * dtp,ssize_t bytes)2984 skip_record (st_parameter_dt *dtp, ssize_t bytes)
2985 {
2986 ssize_t rlength, readb;
2987 #define MAX_READ 4096
2988 char p[MAX_READ];
2989
2990 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2991 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2992 return;
2993
2994 /* Direct access files do not generate END conditions,
2995 only I/O errors. */
2996 if (sseek (dtp->u.p.current_unit->s,
2997 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
2998 {
2999 /* Seeking failed, fall back to seeking by reading data. */
3000 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
3001 {
3002 rlength =
3003 (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
3004 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
3005
3006 readb = sread (dtp->u.p.current_unit->s, p, rlength);
3007 if (readb < 0)
3008 {
3009 generate_error (&dtp->common, LIBERROR_OS, NULL);
3010 return;
3011 }
3012
3013 dtp->u.p.current_unit->bytes_left_subrecord -= readb;
3014 }
3015 return;
3016 }
3017 dtp->u.p.current_unit->bytes_left_subrecord = 0;
3018 }
3019
3020
3021 /* Advance to the next record reading unformatted files, taking
3022 care of subrecords. If complete_record is nonzero, we loop
3023 until all subrecords are cleared. */
3024
3025 static void
next_record_r_unf(st_parameter_dt * dtp,int complete_record)3026 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
3027 {
3028 size_t bytes;
3029
3030 bytes = compile_options.record_marker == 0 ?
3031 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
3032
3033 while(1)
3034 {
3035
3036 /* Skip over tail */
3037
3038 skip_record (dtp, bytes);
3039
3040 if ( ! (complete_record && dtp->u.p.current_unit->continued))
3041 return;
3042
3043 us_read (dtp, 1);
3044 }
3045 }
3046
3047
3048 static gfc_offset
min_off(gfc_offset a,gfc_offset b)3049 min_off (gfc_offset a, gfc_offset b)
3050 {
3051 return (a < b ? a : b);
3052 }
3053
3054
3055 /* Space to the next record for read mode. */
3056
3057 static void
next_record_r(st_parameter_dt * dtp,int done)3058 next_record_r (st_parameter_dt *dtp, int done)
3059 {
3060 gfc_offset record;
3061 int bytes_left;
3062 char p;
3063 int cc;
3064
3065 switch (current_mode (dtp))
3066 {
3067 /* No records in unformatted STREAM I/O. */
3068 case UNFORMATTED_STREAM:
3069 return;
3070
3071 case UNFORMATTED_SEQUENTIAL:
3072 next_record_r_unf (dtp, 1);
3073 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3074 break;
3075
3076 case FORMATTED_DIRECT:
3077 case UNFORMATTED_DIRECT:
3078 skip_record (dtp, dtp->u.p.current_unit->bytes_left);
3079 break;
3080
3081 case FORMATTED_STREAM:
3082 case FORMATTED_SEQUENTIAL:
3083 /* read_sf has already terminated input because of an '\n', or
3084 we have hit EOF. */
3085 if (dtp->u.p.sf_seen_eor)
3086 {
3087 dtp->u.p.sf_seen_eor = 0;
3088 break;
3089 }
3090
3091 if (is_internal_unit (dtp))
3092 {
3093 if (is_array_io (dtp))
3094 {
3095 int finished;
3096
3097 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
3098 &finished);
3099 if (!done && finished)
3100 hit_eof (dtp);
3101
3102 /* Now seek to this record. */
3103 record = record * dtp->u.p.current_unit->recl;
3104 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
3105 {
3106 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3107 break;
3108 }
3109 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3110 }
3111 else
3112 {
3113 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
3114 bytes_left = min_off (bytes_left,
3115 ssize (dtp->u.p.current_unit->s)
3116 - stell (dtp->u.p.current_unit->s));
3117 if (sseek (dtp->u.p.current_unit->s,
3118 bytes_left, SEEK_CUR) < 0)
3119 {
3120 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3121 break;
3122 }
3123 dtp->u.p.current_unit->bytes_left
3124 = dtp->u.p.current_unit->recl;
3125 }
3126 break;
3127 }
3128 else
3129 {
3130 do
3131 {
3132 errno = 0;
3133 cc = fbuf_getc (dtp->u.p.current_unit);
3134 if (cc == EOF)
3135 {
3136 if (errno != 0)
3137 generate_error (&dtp->common, LIBERROR_OS, NULL);
3138 else
3139 {
3140 if (is_stream_io (dtp)
3141 || dtp->u.p.current_unit->pad_status == PAD_NO
3142 || dtp->u.p.current_unit->bytes_left
3143 == dtp->u.p.current_unit->recl)
3144 hit_eof (dtp);
3145 }
3146 break;
3147 }
3148
3149 if (is_stream_io (dtp))
3150 dtp->u.p.current_unit->strm_pos++;
3151
3152 p = (char) cc;
3153 }
3154 while (p != '\n');
3155 }
3156 break;
3157 }
3158 }
3159
3160
3161 /* Small utility function to write a record marker, taking care of
3162 byte swapping and of choosing the correct size. */
3163
3164 static int
write_us_marker(st_parameter_dt * dtp,const gfc_offset buf)3165 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
3166 {
3167 size_t len;
3168 GFC_INTEGER_4 buf4;
3169 GFC_INTEGER_8 buf8;
3170
3171 if (compile_options.record_marker == 0)
3172 len = sizeof (GFC_INTEGER_4);
3173 else
3174 len = compile_options.record_marker;
3175
3176 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3177 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
3178 {
3179 switch (len)
3180 {
3181 case sizeof (GFC_INTEGER_4):
3182 buf4 = buf;
3183 return swrite (dtp->u.p.current_unit->s, &buf4, len);
3184 break;
3185
3186 case sizeof (GFC_INTEGER_8):
3187 buf8 = buf;
3188 return swrite (dtp->u.p.current_unit->s, &buf8, len);
3189 break;
3190
3191 default:
3192 runtime_error ("Illegal value for record marker");
3193 break;
3194 }
3195 }
3196 else
3197 {
3198 uint32_t u32;
3199 uint64_t u64;
3200 switch (len)
3201 {
3202 case sizeof (GFC_INTEGER_4):
3203 buf4 = buf;
3204 memcpy (&u32, &buf4, sizeof (u32));
3205 u32 = __builtin_bswap32 (u32);
3206 return swrite (dtp->u.p.current_unit->s, &u32, len);
3207 break;
3208
3209 case sizeof (GFC_INTEGER_8):
3210 buf8 = buf;
3211 memcpy (&u64, &buf8, sizeof (u64));
3212 u64 = __builtin_bswap64 (u64);
3213 return swrite (dtp->u.p.current_unit->s, &u64, len);
3214 break;
3215
3216 default:
3217 runtime_error ("Illegal value for record marker");
3218 break;
3219 }
3220 }
3221
3222 }
3223
3224 /* Position to the next (sub)record in write mode for
3225 unformatted sequential files. */
3226
3227 static void
next_record_w_unf(st_parameter_dt * dtp,int next_subrecord)3228 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
3229 {
3230 gfc_offset m, m_write, record_marker;
3231
3232 /* Bytes written. */
3233 m = dtp->u.p.current_unit->recl_subrecord
3234 - dtp->u.p.current_unit->bytes_left_subrecord;
3235
3236 if (compile_options.record_marker == 0)
3237 record_marker = sizeof (GFC_INTEGER_4);
3238 else
3239 record_marker = compile_options.record_marker;
3240
3241 /* Seek to the head and overwrite the bogus length with the real
3242 length. */
3243
3244 if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
3245 SEEK_CUR) < 0))
3246 goto io_error;
3247
3248 if (next_subrecord)
3249 m_write = -m;
3250 else
3251 m_write = m;
3252
3253 if (unlikely (write_us_marker (dtp, m_write) < 0))
3254 goto io_error;
3255
3256 /* Seek past the end of the current record. */
3257
3258 if (unlikely (sseek (dtp->u.p.current_unit->s, m, SEEK_CUR) < 0))
3259 goto io_error;
3260
3261 /* Write the length tail. If we finish a record containing
3262 subrecords, we write out the negative length. */
3263
3264 if (dtp->u.p.current_unit->continued)
3265 m_write = -m;
3266 else
3267 m_write = m;
3268
3269 if (unlikely (write_us_marker (dtp, m_write) < 0))
3270 goto io_error;
3271
3272 return;
3273
3274 io_error:
3275 generate_error (&dtp->common, LIBERROR_OS, NULL);
3276 return;
3277
3278 }
3279
3280
3281 /* Utility function like memset() but operating on streams. Return
3282 value is same as for POSIX write(). */
3283
3284 static ssize_t
sset(stream * s,int c,ssize_t nbyte)3285 sset (stream * s, int c, ssize_t nbyte)
3286 {
3287 #define WRITE_CHUNK 256
3288 char p[WRITE_CHUNK];
3289 ssize_t bytes_left, trans;
3290
3291 if (nbyte < WRITE_CHUNK)
3292 memset (p, c, nbyte);
3293 else
3294 memset (p, c, WRITE_CHUNK);
3295
3296 bytes_left = nbyte;
3297 while (bytes_left > 0)
3298 {
3299 trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
3300 trans = swrite (s, p, trans);
3301 if (trans <= 0)
3302 return trans;
3303 bytes_left -= trans;
3304 }
3305
3306 return nbyte - bytes_left;
3307 }
3308
3309
3310 /* Position to the next record in write mode. */
3311
3312 static void
next_record_w(st_parameter_dt * dtp,int done)3313 next_record_w (st_parameter_dt *dtp, int done)
3314 {
3315 gfc_offset m, record, max_pos;
3316 int length;
3317
3318 /* Zero counters for X- and T-editing. */
3319 max_pos = dtp->u.p.max_pos;
3320 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
3321
3322 switch (current_mode (dtp))
3323 {
3324 /* No records in unformatted STREAM I/O. */
3325 case UNFORMATTED_STREAM:
3326 return;
3327
3328 case FORMATTED_DIRECT:
3329 if (dtp->u.p.current_unit->bytes_left == 0)
3330 break;
3331
3332 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3333 fbuf_flush (dtp->u.p.current_unit, WRITING);
3334 if (sset (dtp->u.p.current_unit->s, ' ',
3335 dtp->u.p.current_unit->bytes_left)
3336 != dtp->u.p.current_unit->bytes_left)
3337 goto io_error;
3338
3339 break;
3340
3341 case UNFORMATTED_DIRECT:
3342 if (dtp->u.p.current_unit->bytes_left > 0)
3343 {
3344 length = (int) dtp->u.p.current_unit->bytes_left;
3345 if (sset (dtp->u.p.current_unit->s, 0, length) != length)
3346 goto io_error;
3347 }
3348 break;
3349
3350 case UNFORMATTED_SEQUENTIAL:
3351 next_record_w_unf (dtp, 0);
3352 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3353 break;
3354
3355 case FORMATTED_STREAM:
3356 case FORMATTED_SEQUENTIAL:
3357
3358 if (is_internal_unit (dtp))
3359 {
3360 char *p;
3361 if (is_array_io (dtp))
3362 {
3363 int finished;
3364
3365 length = (int) dtp->u.p.current_unit->bytes_left;
3366
3367 /* If the farthest position reached is greater than current
3368 position, adjust the position and set length to pad out
3369 whats left. Otherwise just pad whats left.
3370 (for character array unit) */
3371 m = dtp->u.p.current_unit->recl
3372 - dtp->u.p.current_unit->bytes_left;
3373 if (max_pos > m)
3374 {
3375 length = (int) (max_pos - m);
3376 if (sseek (dtp->u.p.current_unit->s,
3377 length, SEEK_CUR) < 0)
3378 {
3379 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3380 return;
3381 }
3382 length = (int) (dtp->u.p.current_unit->recl - max_pos);
3383 }
3384
3385 p = write_block (dtp, length);
3386 if (p == NULL)
3387 return;
3388
3389 if (unlikely (is_char4_unit (dtp)))
3390 {
3391 gfc_char4_t *p4 = (gfc_char4_t *) p;
3392 memset4 (p4, ' ', length);
3393 }
3394 else
3395 memset (p, ' ', length);
3396
3397 /* Now that the current record has been padded out,
3398 determine where the next record in the array is. */
3399 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
3400 &finished);
3401 if (finished)
3402 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3403
3404 /* Now seek to this record */
3405 record = record * dtp->u.p.current_unit->recl;
3406
3407 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
3408 {
3409 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3410 return;
3411 }
3412
3413 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3414 }
3415 else
3416 {
3417 length = 1;
3418
3419 /* If this is the last call to next_record move to the farthest
3420 position reached and set length to pad out the remainder
3421 of the record. (for character scaler unit) */
3422 if (done)
3423 {
3424 m = dtp->u.p.current_unit->recl
3425 - dtp->u.p.current_unit->bytes_left;
3426 if (max_pos > m)
3427 {
3428 length = (int) (max_pos - m);
3429 if (sseek (dtp->u.p.current_unit->s,
3430 length, SEEK_CUR) < 0)
3431 {
3432 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3433 return;
3434 }
3435 length = (int) (dtp->u.p.current_unit->recl - max_pos);
3436 }
3437 else
3438 length = (int) dtp->u.p.current_unit->bytes_left;
3439 }
3440 if (length > 0)
3441 {
3442 p = write_block (dtp, length);
3443 if (p == NULL)
3444 return;
3445
3446 if (unlikely (is_char4_unit (dtp)))
3447 {
3448 gfc_char4_t *p4 = (gfc_char4_t *) p;
3449 memset4 (p4, (gfc_char4_t) ' ', length);
3450 }
3451 else
3452 memset (p, ' ', length);
3453 }
3454 }
3455 }
3456 else
3457 {
3458 #ifdef HAVE_CRLF
3459 const int len = 2;
3460 #else
3461 const int len = 1;
3462 #endif
3463 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3464 char * p = fbuf_alloc (dtp->u.p.current_unit, len);
3465 if (!p)
3466 goto io_error;
3467 #ifdef HAVE_CRLF
3468 *(p++) = '\r';
3469 #endif
3470 *p = '\n';
3471 if (is_stream_io (dtp))
3472 {
3473 dtp->u.p.current_unit->strm_pos += len;
3474 if (dtp->u.p.current_unit->strm_pos
3475 < ssize (dtp->u.p.current_unit->s))
3476 unit_truncate (dtp->u.p.current_unit,
3477 dtp->u.p.current_unit->strm_pos - 1,
3478 &dtp->common);
3479 }
3480 }
3481
3482 break;
3483
3484 io_error:
3485 generate_error (&dtp->common, LIBERROR_OS, NULL);
3486 break;
3487 }
3488 }
3489
3490 /* Position to the next record, which means moving to the end of the
3491 current record. This can happen under several different
3492 conditions. If the done flag is not set, we get ready to process
3493 the next record. */
3494
3495 void
next_record(st_parameter_dt * dtp,int done)3496 next_record (st_parameter_dt *dtp, int done)
3497 {
3498 gfc_offset fp; /* File position. */
3499
3500 dtp->u.p.current_unit->read_bad = 0;
3501
3502 if (dtp->u.p.mode == READING)
3503 next_record_r (dtp, done);
3504 else
3505 next_record_w (dtp, done);
3506
3507 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3508
3509 if (!is_stream_io (dtp))
3510 {
3511 /* Since we have changed the position, set it to unspecified so
3512 that INQUIRE(POSITION=) knows it needs to look into it. */
3513 if (done)
3514 dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED;
3515
3516 dtp->u.p.current_unit->current_record = 0;
3517 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
3518 {
3519 fp = stell (dtp->u.p.current_unit->s);
3520 /* Calculate next record, rounding up partial records. */
3521 dtp->u.p.current_unit->last_record =
3522 (fp + dtp->u.p.current_unit->recl) /
3523 dtp->u.p.current_unit->recl - 1;
3524 }
3525 else
3526 dtp->u.p.current_unit->last_record++;
3527 }
3528
3529 if (!done)
3530 pre_position (dtp);
3531
3532 smarkeor (dtp->u.p.current_unit->s);
3533 }
3534
3535
3536 /* Finalize the current data transfer. For a nonadvancing transfer,
3537 this means advancing to the next record. For internal units close the
3538 stream associated with the unit. */
3539
3540 static void
finalize_transfer(st_parameter_dt * dtp)3541 finalize_transfer (st_parameter_dt *dtp)
3542 {
3543 GFC_INTEGER_4 cf = dtp->common.flags;
3544
3545 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
3546 *dtp->size = dtp->u.p.size_used;
3547
3548 if (dtp->u.p.eor_condition)
3549 {
3550 generate_error (&dtp->common, LIBERROR_EOR, NULL);
3551 goto done;
3552 }
3553
3554 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
3555 {
3556 if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
3557 dtp->u.p.current_unit->current_record = 0;
3558 goto done;
3559 }
3560
3561 if ((dtp->u.p.ionml != NULL)
3562 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
3563 {
3564 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
3565 namelist_read (dtp);
3566 else
3567 namelist_write (dtp);
3568 }
3569
3570 dtp->u.p.transfer = NULL;
3571 if (dtp->u.p.current_unit == NULL)
3572 goto done;
3573
3574 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
3575 {
3576 finish_list_read (dtp);
3577 goto done;
3578 }
3579
3580 if (dtp->u.p.mode == WRITING)
3581 dtp->u.p.current_unit->previous_nonadvancing_write
3582 = dtp->u.p.advance_status == ADVANCE_NO;
3583
3584 if (is_stream_io (dtp))
3585 {
3586 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3587 && dtp->u.p.advance_status != ADVANCE_NO)
3588 next_record (dtp, 1);
3589
3590 goto done;
3591 }
3592
3593 dtp->u.p.current_unit->current_record = 0;
3594
3595 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
3596 {
3597 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3598 dtp->u.p.seen_dollar = 0;
3599 goto done;
3600 }
3601
3602 /* For non-advancing I/O, save the current maximum position for use in the
3603 next I/O operation if needed. */
3604 if (dtp->u.p.advance_status == ADVANCE_NO)
3605 {
3606 if (dtp->u.p.skips > 0)
3607 {
3608 int tmp;
3609 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
3610 tmp = (int)(dtp->u.p.current_unit->recl
3611 - dtp->u.p.current_unit->bytes_left);
3612 dtp->u.p.max_pos =
3613 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
3614 dtp->u.p.skips = 0;
3615 }
3616 int bytes_written = (int) (dtp->u.p.current_unit->recl
3617 - dtp->u.p.current_unit->bytes_left);
3618 dtp->u.p.current_unit->saved_pos =
3619 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
3620 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3621 goto done;
3622 }
3623 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3624 && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
3625 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3626
3627 dtp->u.p.current_unit->saved_pos = 0;
3628
3629 next_record (dtp, 1);
3630
3631 done:
3632 #ifdef HAVE_USELOCALE
3633 if (dtp->u.p.old_locale != (locale_t) 0)
3634 {
3635 uselocale (dtp->u.p.old_locale);
3636 dtp->u.p.old_locale = (locale_t) 0;
3637 }
3638 #else
3639 __gthread_mutex_lock (&old_locale_lock);
3640 if (!--old_locale_ctr)
3641 {
3642 setlocale (LC_NUMERIC, old_locale);
3643 old_locale = NULL;
3644 }
3645 __gthread_mutex_unlock (&old_locale_lock);
3646 #endif
3647 }
3648
3649 /* Transfer function for IOLENGTH. It doesn't actually do any
3650 data transfer, it just updates the length counter. */
3651
3652 static void
iolength_transfer(st_parameter_dt * dtp,bt type,void * dest,int kind,size_t size,size_t nelems)3653 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
3654 void *dest __attribute__ ((unused)),
3655 int kind __attribute__((unused)),
3656 size_t size, size_t nelems)
3657 {
3658 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3659 *dtp->iolength += (GFC_IO_INT) (size * nelems);
3660 }
3661
3662
3663 /* Initialize the IOLENGTH data transfer. This function is in essence
3664 a very much simplified version of data_transfer_init(), because it
3665 doesn't have to deal with units at all. */
3666
3667 static void
iolength_transfer_init(st_parameter_dt * dtp)3668 iolength_transfer_init (st_parameter_dt *dtp)
3669 {
3670 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3671 *dtp->iolength = 0;
3672
3673 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
3674
3675 /* Set up the subroutine that will handle the transfers. */
3676
3677 dtp->u.p.transfer = iolength_transfer;
3678 }
3679
3680
3681 /* Library entry point for the IOLENGTH form of the INQUIRE
3682 statement. The IOLENGTH form requires no I/O to be performed, but
3683 it must still be a runtime library call so that we can determine
3684 the iolength for dynamic arrays and such. */
3685
3686 extern void st_iolength (st_parameter_dt *);
3687 export_proto(st_iolength);
3688
3689 void
st_iolength(st_parameter_dt * dtp)3690 st_iolength (st_parameter_dt *dtp)
3691 {
3692 library_start (&dtp->common);
3693 iolength_transfer_init (dtp);
3694 }
3695
3696 extern void st_iolength_done (st_parameter_dt *);
3697 export_proto(st_iolength_done);
3698
3699 void
st_iolength_done(st_parameter_dt * dtp)3700 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
3701 {
3702 free_ionml (dtp);
3703 library_end ();
3704 }
3705
3706
3707 /* The READ statement. */
3708
3709 extern void st_read (st_parameter_dt *);
3710 export_proto(st_read);
3711
3712 void
st_read(st_parameter_dt * dtp)3713 st_read (st_parameter_dt *dtp)
3714 {
3715 library_start (&dtp->common);
3716
3717 data_transfer_init (dtp, 1);
3718 }
3719
3720 extern void st_read_done (st_parameter_dt *);
3721 export_proto(st_read_done);
3722
3723 void
st_read_done(st_parameter_dt * dtp)3724 st_read_done (st_parameter_dt *dtp)
3725 {
3726 finalize_transfer (dtp);
3727
3728 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3729 {
3730 free_format_data (dtp->u.p.fmt);
3731 free_format (dtp);
3732 }
3733
3734 free_ionml (dtp);
3735
3736 if (dtp->u.p.current_unit != NULL)
3737 unlock_unit (dtp->u.p.current_unit);
3738
3739 free_internal_unit (dtp);
3740
3741 library_end ();
3742 }
3743
3744 extern void st_write (st_parameter_dt *);
3745 export_proto(st_write);
3746
3747 void
st_write(st_parameter_dt * dtp)3748 st_write (st_parameter_dt *dtp)
3749 {
3750 library_start (&dtp->common);
3751 data_transfer_init (dtp, 0);
3752 }
3753
3754 extern void st_write_done (st_parameter_dt *);
3755 export_proto(st_write_done);
3756
3757 void
st_write_done(st_parameter_dt * dtp)3758 st_write_done (st_parameter_dt *dtp)
3759 {
3760 finalize_transfer (dtp);
3761
3762 /* Deal with endfile conditions associated with sequential files. */
3763
3764 if (dtp->u.p.current_unit != NULL
3765 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3766 switch (dtp->u.p.current_unit->endfile)
3767 {
3768 case AT_ENDFILE: /* Remain at the endfile record. */
3769 break;
3770
3771 case AFTER_ENDFILE:
3772 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
3773 break;
3774
3775 case NO_ENDFILE:
3776 /* Get rid of whatever is after this record. */
3777 if (!is_internal_unit (dtp))
3778 unit_truncate (dtp->u.p.current_unit,
3779 stell (dtp->u.p.current_unit->s),
3780 &dtp->common);
3781 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3782 break;
3783 }
3784
3785 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3786 {
3787 free_format_data (dtp->u.p.fmt);
3788 free_format (dtp);
3789 }
3790
3791 free_ionml (dtp);
3792
3793 if (dtp->u.p.current_unit != NULL)
3794 unlock_unit (dtp->u.p.current_unit);
3795
3796 free_internal_unit (dtp);
3797
3798 library_end ();
3799 }
3800
3801
3802 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3803 void
st_wait(st_parameter_wait * wtp)3804 st_wait (st_parameter_wait *wtp __attribute__((unused)))
3805 {
3806 }
3807
3808
3809 /* Receives the scalar information for namelist objects and stores it
3810 in a linked list of namelist_info types. */
3811
3812 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
3813 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
3814 export_proto(st_set_nml_var);
3815
3816
3817 void
st_set_nml_var(st_parameter_dt * dtp,void * var_addr,char * var_name,GFC_INTEGER_4 len,gfc_charlen_type string_length,GFC_INTEGER_4 dtype)3818 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
3819 GFC_INTEGER_4 len, gfc_charlen_type string_length,
3820 GFC_INTEGER_4 dtype)
3821 {
3822 namelist_info *t1 = NULL;
3823 namelist_info *nml;
3824 size_t var_name_len = strlen (var_name);
3825
3826 nml = (namelist_info*) xmalloc (sizeof (namelist_info));
3827
3828 nml->mem_pos = var_addr;
3829
3830 nml->var_name = (char*) xmalloc (var_name_len + 1);
3831 memcpy (nml->var_name, var_name, var_name_len);
3832 nml->var_name[var_name_len] = '\0';
3833
3834 nml->len = (int) len;
3835 nml->string_length = (index_type) string_length;
3836
3837 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
3838 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
3839 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
3840
3841 if (nml->var_rank > 0)
3842 {
3843 nml->dim = (descriptor_dimension*)
3844 xmallocarray (nml->var_rank, sizeof (descriptor_dimension));
3845 nml->ls = (array_loop_spec*)
3846 xmallocarray (nml->var_rank, sizeof (array_loop_spec));
3847 }
3848 else
3849 {
3850 nml->dim = NULL;
3851 nml->ls = NULL;
3852 }
3853
3854 nml->next = NULL;
3855
3856 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
3857 {
3858 dtp->common.flags |= IOPARM_DT_IONML_SET;
3859 dtp->u.p.ionml = nml;
3860 }
3861 else
3862 {
3863 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
3864 t1->next = nml;
3865 }
3866 }
3867
3868 /* Store the dimensional information for the namelist object. */
3869 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
3870 index_type, index_type,
3871 index_type);
3872 export_proto(st_set_nml_var_dim);
3873
3874 void
st_set_nml_var_dim(st_parameter_dt * dtp,GFC_INTEGER_4 n_dim,index_type stride,index_type lbound,index_type ubound)3875 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
3876 index_type stride, index_type lbound,
3877 index_type ubound)
3878 {
3879 namelist_info * nml;
3880 int n;
3881
3882 n = (int)n_dim;
3883
3884 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
3885
3886 GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
3887 }
3888
3889
3890 /* Once upon a time, a poor innocent Fortran program was reading a
3891 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3892 the OS doesn't tell whether we're at the EOF or whether we already
3893 went past it. Luckily our hero, libgfortran, keeps track of this.
3894 Call this function when you detect an EOF condition. See Section
3895 9.10.2 in F2003. */
3896
3897 void
hit_eof(st_parameter_dt * dtp)3898 hit_eof (st_parameter_dt * dtp)
3899 {
3900 dtp->u.p.current_unit->flags.position = POSITION_APPEND;
3901
3902 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3903 switch (dtp->u.p.current_unit->endfile)
3904 {
3905 case NO_ENDFILE:
3906 case AT_ENDFILE:
3907 generate_error (&dtp->common, LIBERROR_END, NULL);
3908 if (!is_internal_unit (dtp) && !dtp->u.p.namelist_mode)
3909 {
3910 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
3911 dtp->u.p.current_unit->current_record = 0;
3912 }
3913 else
3914 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3915 break;
3916
3917 case AFTER_ENDFILE:
3918 generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
3919 dtp->u.p.current_unit->current_record = 0;
3920 break;
3921 }
3922 else
3923 {
3924 /* Non-sequential files don't have an ENDFILE record, so we
3925 can't be at AFTER_ENDFILE. */
3926 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3927 generate_error (&dtp->common, LIBERROR_END, NULL);
3928 dtp->u.p.current_unit->current_record = 0;
3929 }
3930 }
3931