projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR libfortran/48852 (Invalid spaces in list-directed output of complex constants)
[gcc.git] / libgfortran / io / transfer.c
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
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 *
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 *
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 *
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 *
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
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 *
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
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
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
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
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
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 *
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
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
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
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
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 dtp->u.p.sf_seen_eor = 0;
1438 }
1439 if (dtp->u.p.skips < 0)
1440 {
1441 if (is_internal_unit (dtp))
1442 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1443 else
1444 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1445 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1446 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1447 }
1448 else
1449 read_x (dtp, dtp->u.p.skips);
1450 break;
1451
1452 case FMT_S:
1453 consume_data_flag = 0;
1454 dtp->u.p.sign_status = SIGN_S;
1455 break;
1456
1457 case FMT_SS:
1458 consume_data_flag = 0;
1459 dtp->u.p.sign_status = SIGN_SS;
1460 break;
1461
1462 case FMT_SP:
1463 consume_data_flag = 0;
1464 dtp->u.p.sign_status = SIGN_SP;
1465 break;
1466
1467 case FMT_BN:
1468 consume_data_flag = 0 ;
1469 dtp->u.p.blank_status = BLANK_NULL;
1470 break;
1471
1472 case FMT_BZ:
1473 consume_data_flag = 0;
1474 dtp->u.p.blank_status = BLANK_ZERO;
1475 break;
1476
1477 case FMT_DC:
1478 consume_data_flag = 0;
1479 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1480 break;
1481
1482 case FMT_DP:
1483 consume_data_flag = 0;
1484 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1485 break;
1486
1487 case FMT_RC:
1488 consume_data_flag = 0;
1489 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1490 break;
1491
1492 case FMT_RD:
1493 consume_data_flag = 0;
1494 dtp->u.p.current_unit->round_status = ROUND_DOWN;
1495 break;
1496
1497 case FMT_RN:
1498 consume_data_flag = 0;
1499 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1500 break;
1501
1502 case FMT_RP:
1503 consume_data_flag = 0;
1504 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1505 break;
1506
1507 case FMT_RU:
1508 consume_data_flag = 0;
1509 dtp->u.p.current_unit->round_status = ROUND_UP;
1510 break;
1511
1512 case FMT_RZ:
1513 consume_data_flag = 0;
1514 dtp->u.p.current_unit->round_status = ROUND_ZERO;
1515 break;
1516
1517 case FMT_P:
1518 consume_data_flag = 0;
1519 dtp->u.p.scale_factor = f->u.k;
1520 break;
1521
1522 case FMT_DOLLAR:
1523 consume_data_flag = 0;
1524 dtp->u.p.seen_dollar = 1;
1525 break;
1526
1527 case FMT_SLASH:
1528 consume_data_flag = 0;
1529 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1530 next_record (dtp, 0);
1531 break;
1532
1533 case FMT_COLON:
1534 /* A colon descriptor causes us to exit this loop (in
1535 particular preventing another / descriptor from being
1536 processed) unless there is another data item to be
1537 transferred. */
1538 consume_data_flag = 0;
1539 if (n == 0)
1540 return;
1541 break;
1542
1543 default:
1544 internal_error (&dtp->common, "Bad format node");
1545 }
1546
1547 /* Adjust the item count and data pointer. */
1548
1549 if ((consume_data_flag > 0) && (n > 0))
1550 {
1551 n--;
1552 p = ((char *) p) + size;
1553 }
1554
1555 dtp->u.p.skips = 0;
1556
1557 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1558 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1559 }
1560
1561 return;
1562
1563 /* Come here when we need a data descriptor but don't have one. We
1564 push the current format node back onto the input, then return and
1565 let the user program call us back with the data. */
1566 need_read_data:
1567 unget_format (dtp, f);
1568 }
1569
1570
1571 static void
1572 formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1573 size_t size)
1574 {
1575 int pos, bytes_used;
1576 const fnode *f;
1577 format_token t;
1578 int n;
1579 int consume_data_flag;
1580
1581 /* Change a complex data item into a pair of reals. */
1582
1583 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1584 if (type == BT_COMPLEX)
1585 {
1586 type = BT_REAL;
1587 size /= 2;
1588 }
1589
1590 /* If there's an EOR condition, we simulate finalizing the transfer
1591 by doing nothing. */
1592 if (dtp->u.p.eor_condition)
1593 return;
1594
1595 /* Set this flag so that commas in reads cause the read to complete before
1596 the entire field has been read. The next read field will start right after
1597 the comma in the stream. (Set to 0 for character reads). */
1598 dtp->u.p.sf_read_comma =
1599 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
1600
1601 for (;;)
1602 {
1603 /* If reversion has occurred and there is another real data item,
1604 then we have to move to the next record. */
1605 if (dtp->u.p.reversion_flag && n > 0)
1606 {
1607 dtp->u.p.reversion_flag = 0;
1608 next_record (dtp, 0);
1609 }
1610
1611 consume_data_flag = 1;
1612 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1613 break;
1614
1615 f = next_format (dtp);
1616 if (f == NULL)
1617 {
1618 /* No data descriptors left. */
1619 if (unlikely (n > 0))
1620 generate_error (&dtp->common, LIBERROR_FORMAT,
1621 "Insufficient data descriptors in format after reversion");
1622 return;
1623 }
1624
1625 /* Now discharge T, TR and X movements to the right. This is delayed
1626 until a data producing format to suppress trailing spaces. */
1627
1628 t = f->format;
1629 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
1630 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
1631 || t == FMT_Z || t == FMT_F || t == FMT_E
1632 || t == FMT_EN || t == FMT_ES || t == FMT_G
1633 || t == FMT_L || t == FMT_A || t == FMT_D))
1634 || t == FMT_STRING))
1635 {
1636 if (dtp->u.p.skips > 0)
1637 {
1638 int tmp;
1639 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1640 tmp = (int)(dtp->u.p.current_unit->recl
1641 - dtp->u.p.current_unit->bytes_left);
1642 dtp->u.p.max_pos =
1643 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
1644 dtp->u.p.skips = 0;
1645 }
1646 if (dtp->u.p.skips < 0)
1647 {
1648 if (is_internal_unit (dtp))
1649 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1650 else
1651 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1652 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1653 }
1654 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1655 }
1656
1657 bytes_used = (int)(dtp->u.p.current_unit->recl
1658 - dtp->u.p.current_unit->bytes_left);
1659
1660 if (is_stream_io(dtp))
1661 bytes_used = 0;
1662
1663 switch (t)
1664 {
1665 case FMT_I:
1666 if (n == 0)
1667 goto need_data;
1668 if (require_type (dtp, BT_INTEGER, type, f))
1669 return;
1670 write_i (dtp, f, p, kind);
1671 break;
1672
1673 case FMT_B:
1674 if (n == 0)
1675 goto need_data;
1676 if (!(compile_options.allow_std & GFC_STD_GNU)
1677 && require_numeric_type (dtp, type, f))
1678 return;
1679 if (!(compile_options.allow_std & GFC_STD_F2008)
1680 && require_type (dtp, BT_INTEGER, type, f))
1681 return;
1682 write_b (dtp, f, p, kind);
1683 break;
1684
1685 case FMT_O:
1686 if (n == 0)
1687 goto need_data;
1688 if (!(compile_options.allow_std & GFC_STD_GNU)
1689 && require_numeric_type (dtp, type, f))
1690 return;
1691 if (!(compile_options.allow_std & GFC_STD_F2008)
1692 && require_type (dtp, BT_INTEGER, type, f))
1693 return;
1694 write_o (dtp, f, p, kind);
1695 break;
1696
1697 case FMT_Z:
1698 if (n == 0)
1699 goto need_data;
1700 if (!(compile_options.allow_std & GFC_STD_GNU)
1701 && require_numeric_type (dtp, type, f))
1702 return;
1703 if (!(compile_options.allow_std & GFC_STD_F2008)
1704 && require_type (dtp, BT_INTEGER, type, f))
1705 return;
1706 write_z (dtp, f, p, kind);
1707 break;
1708
1709 case FMT_A:
1710 if (n == 0)
1711 goto need_data;
1712
1713 /* It is possible to have FMT_A with something not BT_CHARACTER such
1714 as when writing out hollerith strings, so check both type
1715 and kind before calling wide character routines. */
1716 if (type == BT_CHARACTER && kind == 4)
1717 write_a_char4 (dtp, f, p, size);
1718 else
1719 write_a (dtp, f, p, size);
1720 break;
1721
1722 case FMT_L:
1723 if (n == 0)
1724 goto need_data;
1725 write_l (dtp, f, p, kind);
1726 break;
1727
1728 case FMT_D:
1729 if (n == 0)
1730 goto need_data;
1731 if (require_type (dtp, BT_REAL, type, f))
1732 return;
1733 write_d (dtp, f, p, kind);
1734 break;
1735
1736 case FMT_E:
1737 if (n == 0)
1738 goto need_data;
1739 if (require_type (dtp, BT_REAL, type, f))
1740 return;
1741 write_e (dtp, f, p, kind);
1742 break;
1743
1744 case FMT_EN:
1745 if (n == 0)
1746 goto need_data;
1747 if (require_type (dtp, BT_REAL, type, f))
1748 return;
1749 write_en (dtp, f, p, kind);
1750 break;
1751
1752 case FMT_ES:
1753 if (n == 0)
1754 goto need_data;
1755 if (require_type (dtp, BT_REAL, type, f))
1756 return;
1757 write_es (dtp, f, p, kind);
1758 break;
1759
1760 case FMT_F:
1761 if (n == 0)
1762 goto need_data;
1763 if (require_type (dtp, BT_REAL, type, f))
1764 return;
1765 write_f (dtp, f, p, kind);
1766 break;
1767
1768 case FMT_G:
1769 if (n == 0)
1770 goto need_data;
1771 switch (type)
1772 {
1773 case BT_INTEGER:
1774 write_i (dtp, f, p, kind);
1775 break;
1776 case BT_LOGICAL:
1777 write_l (dtp, f, p, kind);
1778 break;
1779 case BT_CHARACTER:
1780 if (kind == 4)
1781 write_a_char4 (dtp, f, p, size);
1782 else
1783 write_a (dtp, f, p, size);
1784 break;
1785 case BT_REAL:
1786 if (f->u.real.w == 0)
1787 write_real_g0 (dtp, p, kind, f->u.real.d);
1788 else
1789 write_d (dtp, f, p, kind);
1790 break;
1791 default:
1792 internal_error (&dtp->common,
1793 "formatted_transfer(): Bad type");
1794 }
1795 break;
1796
1797 case FMT_STRING:
1798 consume_data_flag = 0;
1799 write_constant_string (dtp, f);
1800 break;
1801
1802 /* Format codes that don't transfer data. */
1803 case FMT_X:
1804 case FMT_TR:
1805 consume_data_flag = 0;
1806
1807 dtp->u.p.skips += f->u.n;
1808 pos = bytes_used + dtp->u.p.skips - 1;
1809 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1810 /* Writes occur just before the switch on f->format, above, so
1811 that trailing blanks are suppressed, unless we are doing a
1812 non-advancing write in which case we want to output the blanks
1813 now. */
1814 if (dtp->u.p.advance_status == ADVANCE_NO)
1815 {
1816 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1817 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1818 }
1819 break;
1820
1821 case FMT_TL:
1822 case FMT_T:
1823 consume_data_flag = 0;
1824
1825 if (f->format == FMT_TL)
1826 {
1827
1828 /* Handle the special case when no bytes have been used yet.
1829 Cannot go below zero. */
1830 if (bytes_used == 0)
1831 {
1832 dtp->u.p.pending_spaces -= f->u.n;
1833 dtp->u.p.skips -= f->u.n;
1834 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1835 }
1836
1837 pos = bytes_used - f->u.n;
1838 }
1839 else /* FMT_T */
1840 pos = f->u.n - dtp->u.p.pending_spaces - 1;
1841
1842 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1843 left tab limit. We do not check if the position has gone
1844 beyond the end of record because a subsequent tab could
1845 bring us back again. */
1846 pos = pos < 0 ? 0 : pos;
1847
1848 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1849 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1850 + pos - dtp->u.p.max_pos;
1851 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1852 ? 0 : dtp->u.p.pending_spaces;
1853 break;
1854
1855 case FMT_S:
1856 consume_data_flag = 0;
1857 dtp->u.p.sign_status = SIGN_S;
1858 break;
1859
1860 case FMT_SS:
1861 consume_data_flag = 0;
1862 dtp->u.p.sign_status = SIGN_SS;
1863 break;
1864
1865 case FMT_SP:
1866 consume_data_flag = 0;
1867 dtp->u.p.sign_status = SIGN_SP;
1868 break;
1869
1870 case FMT_BN:
1871 consume_data_flag = 0 ;
1872 dtp->u.p.blank_status = BLANK_NULL;
1873 break;
1874
1875 case FMT_BZ:
1876 consume_data_flag = 0;
1877 dtp->u.p.blank_status = BLANK_ZERO;
1878 break;
1879
1880 case FMT_DC:
1881 consume_data_flag = 0;
1882 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1883 break;
1884
1885 case FMT_DP:
1886 consume_data_flag = 0;
1887 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1888 break;
1889
1890 case FMT_RC:
1891 consume_data_flag = 0;
1892 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1893 break;
1894
1895 case FMT_RD:
1896 consume_data_flag = 0;
1897 dtp->u.p.current_unit->round_status = ROUND_DOWN;
1898 break;
1899
1900 case FMT_RN:
1901 consume_data_flag = 0;
1902 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1903 break;
1904
1905 case FMT_RP:
1906 consume_data_flag = 0;
1907 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1908 break;
1909
1910 case FMT_RU:
1911 consume_data_flag = 0;
1912 dtp->u.p.current_unit->round_status = ROUND_UP;
1913 break;
1914
1915 case FMT_RZ:
1916 consume_data_flag = 0;
1917 dtp->u.p.current_unit->round_status = ROUND_ZERO;
1918 break;
1919
1920 case FMT_P:
1921 consume_data_flag = 0;
1922 dtp->u.p.scale_factor = f->u.k;
1923 break;
1924
1925 case FMT_DOLLAR:
1926 consume_data_flag = 0;
1927 dtp->u.p.seen_dollar = 1;
1928 break;
1929
1930 case FMT_SLASH:
1931 consume_data_flag = 0;
1932 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1933 next_record (dtp, 0);
1934 break;
1935
1936 case FMT_COLON:
1937 /* A colon descriptor causes us to exit this loop (in
1938 particular preventing another / descriptor from being
1939 processed) unless there is another data item to be
1940 transferred. */
1941 consume_data_flag = 0;
1942 if (n == 0)
1943 return;
1944 break;
1945
1946 default:
1947 internal_error (&dtp->common, "Bad format node");
1948 }
1949
1950 /* Adjust the item count and data pointer. */
1951
1952 if ((consume_data_flag > 0) && (n > 0))
1953 {
1954 n--;
1955 p = ((char *) p) + size;
1956 }
1957
1958 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1959 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1960 }
1961
1962 return;
1963
1964 /* Come here when we need a data descriptor but don't have one. We
1965 push the current format node back onto the input, then return and
1966 let the user program call us back with the data. */
1967 need_data:
1968 unget_format (dtp, f);
1969 }
1970
1971 /* This function is first called from data_init_transfer to initiate the loop
1972 over each item in the format, transferring data as required. Subsequent
1973 calls to this function occur for each data item foound in the READ/WRITE
1974 statement. The item_count is incremented for each call. Since the first
1975 call is from data_transfer_init, the item_count is always one greater than
1976 the actual count number of the item being transferred. */
1977
1978 static void
1979 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1980 size_t size, size_t nelems)
1981 {
1982 size_t elem;
1983 char *tmp;
1984
1985 tmp = (char *) p;
1986 size_t stride = type == BT_CHARACTER ?
1987 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1988 if (dtp->u.p.mode == READING)
1989 {
1990 /* Big loop over all the elements. */
1991 for (elem = 0; elem < nelems; elem++)
1992 {
1993 dtp->u.p.item_count++;
1994 formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
1995 }
1996 }
1997 else
1998 {
1999 /* Big loop over all the elements. */
2000 for (elem = 0; elem < nelems; elem++)
2001 {
2002 dtp->u.p.item_count++;
2003 formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
2004 }
2005 }
2006 }
2007
2008
2009 /* Data transfer entry points. The type of the data entity is
2010 implicit in the subroutine call. This prevents us from having to
2011 share a common enum with the compiler. */
2012
2013 void
2014 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
2015 {
2016 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2017 return;
2018 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
2019 }
2020
2021 void
2022 transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
2023 {
2024 transfer_integer (dtp, p, kind);
2025 }
2026
2027 void
2028 transfer_real (st_parameter_dt *dtp, void *p, int kind)
2029 {
2030 size_t size;
2031 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2032 return;
2033 size = size_from_real_kind (kind);
2034 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
2035 }
2036
2037 void
2038 transfer_real_write (st_parameter_dt *dtp, void *p, int kind)
2039 {
2040 transfer_real (dtp, p, kind);
2041 }
2042
2043 void
2044 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
2045 {
2046 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2047 return;
2048 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
2049 }
2050
2051 void
2052 transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
2053 {
2054 transfer_logical (dtp, p, kind);
2055 }
2056
2057 void
2058 transfer_character (st_parameter_dt *dtp, void *p, int len)
2059 {
2060 static char *empty_string[0];
2061
2062 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2063 return;
2064
2065 /* Strings of zero length can have p == NULL, which confuses the
2066 transfer routines into thinking we need more data elements. To avoid
2067 this, we give them a nice pointer. */
2068 if (len == 0 && p == NULL)
2069 p = empty_string;
2070
2071 /* Set kind here to 1. */
2072 dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
2073 }
2074
2075 void
2076 transfer_character_write (st_parameter_dt *dtp, void *p, int len)
2077 {
2078 transfer_character (dtp, p, len);
2079 }
2080
2081 void
2082 transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
2083 {
2084 static char *empty_string[0];
2085
2086 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2087 return;
2088
2089 /* Strings of zero length can have p == NULL, which confuses the
2090 transfer routines into thinking we need more data elements. To avoid
2091 this, we give them a nice pointer. */
2092 if (len == 0 && p == NULL)
2093 p = empty_string;
2094
2095 /* Here we pass the actual kind value. */
2096 dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
2097 }
2098
2099 void
2100 transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
2101 {
2102 transfer_character_wide (dtp, p, len, kind);
2103 }
2104
2105 void
2106 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
2107 {
2108 size_t size;
2109 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2110 return;
2111 size = size_from_complex_kind (kind);
2112 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
2113 }
2114
2115 void
2116 transfer_complex_write (st_parameter_dt *dtp, void *p, int kind)
2117 {
2118 transfer_complex (dtp, p, kind);
2119 }
2120
2121 void
2122 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2123 gfc_charlen_type charlen)
2124 {
2125 index_type count[GFC_MAX_DIMENSIONS];
2126 index_type extent[GFC_MAX_DIMENSIONS];
2127 index_type stride[GFC_MAX_DIMENSIONS];
2128 index_type stride0, rank, size, n;
2129 size_t tsize;
2130 char *data;
2131 bt iotype;
2132
2133 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2134 return;
2135
2136 iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
2137 size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
2138
2139 rank = GFC_DESCRIPTOR_RANK (desc);
2140 for (n = 0; n < rank; n++)
2141 {
2142 count[n] = 0;
2143 stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
2144 extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
2145
2146 /* If the extent of even one dimension is zero, then the entire
2147 array section contains zero elements, so we return after writing
2148 a zero array record. */
2149 if (extent[n] <= 0)
2150 {
2151 data = NULL;
2152 tsize = 0;
2153 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2154 return;
2155 }
2156 }
2157
2158 stride0 = stride[0];
2159
2160 /* If the innermost dimension has a stride of 1, we can do the transfer
2161 in contiguous chunks. */
2162 if (stride0 == size)
2163 tsize = extent[0];
2164 else
2165 tsize = 1;
2166
2167 data = GFC_DESCRIPTOR_DATA (desc);
2168
2169 while (data)
2170 {
2171 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2172 data += stride0 * tsize;
2173 count[0] += tsize;
2174 n = 0;
2175 while (count[n] == extent[n])
2176 {
2177 count[n] = 0;
2178 data -= stride[n] * extent[n];
2179 n++;
2180 if (n == rank)
2181 {
2182 data = NULL;
2183 break;
2184 }
2185 else
2186 {
2187 count[n]++;
2188 data += stride[n];
2189 }
2190 }
2191 }
2192 }
2193
2194 void
2195 transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2196 gfc_charlen_type charlen)
2197 {
2198 transfer_array (dtp, desc, kind, charlen);
2199 }
2200
2201 /* Preposition a sequential unformatted file while reading. */
2202
2203 static void
2204 us_read (st_parameter_dt *dtp, int continued)
2205 {
2206 ssize_t n, nr;
2207 GFC_INTEGER_4 i4;
2208 GFC_INTEGER_8 i8;
2209 gfc_offset i;
2210
2211 if (compile_options.record_marker == 0)
2212 n = sizeof (GFC_INTEGER_4);
2213 else
2214 n = compile_options.record_marker;
2215
2216 nr = sread (dtp->u.p.current_unit->s, &i, n);
2217 if (unlikely (nr < 0))
2218 {
2219 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2220 return;
2221 }
2222 else if (nr == 0)
2223 {
2224 hit_eof (dtp);
2225 return; /* end of file */
2226 }
2227 else if (unlikely (n != nr))
2228 {
2229 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2230 return;
2231 }
2232
2233 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2234 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
2235 {
2236 switch (nr)
2237 {
2238 case sizeof(GFC_INTEGER_4):
2239 memcpy (&i4, &i, sizeof (i4));
2240 i = i4;
2241 break;
2242
2243 case sizeof(GFC_INTEGER_8):
2244 memcpy (&i8, &i, sizeof (i8));
2245 i = i8;
2246 break;
2247
2248 default:
2249 runtime_error ("Illegal value for record marker");
2250 break;
2251 }
2252 }
2253 else
2254 {
2255 uint32_t u32;
2256 uint64_t u64;
2257 switch (nr)
2258 {
2259 case sizeof(GFC_INTEGER_4):
2260 memcpy (&u32, &i, sizeof (u32));
2261 u32 = __builtin_bswap32 (u32);
2262 memcpy (&i4, &u32, sizeof (i4));
2263 i = i4;
2264 break;
2265
2266 case sizeof(GFC_INTEGER_8):
2267 memcpy (&u64, &i, sizeof (u64));
2268 u64 = __builtin_bswap64 (u64);
2269 memcpy (&i8, &u64, sizeof (i8));
2270 i = i8;
2271 break;
2272
2273 default:
2274 runtime_error ("Illegal value for record marker");
2275 break;
2276 }
2277 }
2278
2279 if (i >= 0)
2280 {
2281 dtp->u.p.current_unit->bytes_left_subrecord = i;
2282 dtp->u.p.current_unit->continued = 0;
2283 }
2284 else
2285 {
2286 dtp->u.p.current_unit->bytes_left_subrecord = -i;
2287 dtp->u.p.current_unit->continued = 1;
2288 }
2289
2290 if (! continued)
2291 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2292 }
2293
2294
2295 /* Preposition a sequential unformatted file while writing. This
2296 amount to writing a bogus length that will be filled in later. */
2297
2298 static void
2299 us_write (st_parameter_dt *dtp, int continued)
2300 {
2301 ssize_t nbytes;
2302 gfc_offset dummy;
2303
2304 dummy = 0;
2305
2306 if (compile_options.record_marker == 0)
2307 nbytes = sizeof (GFC_INTEGER_4);
2308 else
2309 nbytes = compile_options.record_marker ;
2310
2311 if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
2312 generate_error (&dtp->common, LIBERROR_OS, NULL);
2313
2314 /* For sequential unformatted, if RECL= was not specified in the OPEN
2315 we write until we have more bytes than can fit in the subrecord
2316 markers, then we write a new subrecord. */
2317
2318 dtp->u.p.current_unit->bytes_left_subrecord =
2319 dtp->u.p.current_unit->recl_subrecord;
2320 dtp->u.p.current_unit->continued = continued;
2321 }
2322
2323
2324 /* Position to the next record prior to transfer. We are assumed to
2325 be before the next record. We also calculate the bytes in the next
2326 record. */
2327
2328 static void
2329 pre_position (st_parameter_dt *dtp)
2330 {
2331 if (dtp->u.p.current_unit->current_record)
2332 return; /* Already positioned. */
2333
2334 switch (current_mode (dtp))
2335 {
2336 case FORMATTED_STREAM:
2337 case UNFORMATTED_STREAM:
2338 /* There are no records with stream I/O. If the position was specified
2339 data_transfer_init has already positioned the file. If no position
2340 was specified, we continue from where we last left off. I.e.
2341 there is nothing to do here. */
2342 break;
2343
2344 case UNFORMATTED_SEQUENTIAL:
2345 if (dtp->u.p.mode == READING)
2346 us_read (dtp, 0);
2347 else
2348 us_write (dtp, 0);
2349
2350 break;
2351
2352 case FORMATTED_SEQUENTIAL:
2353 case FORMATTED_DIRECT:
2354 case UNFORMATTED_DIRECT:
2355 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2356 break;
2357 }
2358
2359 dtp->u.p.current_unit->current_record = 1;
2360 }
2361
2362
2363 /* Initialize things for a data transfer. This code is common for
2364 both reading and writing. */
2365
2366 static void
2367 data_transfer_init (st_parameter_dt *dtp, int read_flag)
2368 {
2369 unit_flags u_flags; /* Used for creating a unit if needed. */
2370 GFC_INTEGER_4 cf = dtp->common.flags;
2371 namelist_info *ionml;
2372
2373 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
2374
2375 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2376
2377 dtp->u.p.ionml = ionml;
2378 dtp->u.p.mode = read_flag ? READING : WRITING;
2379
2380 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2381 return;
2382
2383 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2384 dtp->u.p.size_used = 0; /* Initialize the count. */
2385
2386 dtp->u.p.current_unit = get_unit (dtp, 1);
2387 if (dtp->u.p.current_unit->s == NULL)
2388 { /* Open the unit with some default flags. */
2389 st_parameter_open opp;
2390 unit_convert conv;
2391
2392 if (dtp->common.unit < 0)
2393 {
2394 close_unit (dtp->u.p.current_unit);
2395 dtp->u.p.current_unit = NULL;
2396 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2397 "Bad unit number in statement");
2398 return;
2399 }
2400 memset (&u_flags, '\0', sizeof (u_flags));
2401 u_flags.access = ACCESS_SEQUENTIAL;
2402 u_flags.action = ACTION_READWRITE;
2403
2404 /* Is it unformatted? */
2405 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
2406 | IOPARM_DT_IONML_SET)))
2407 u_flags.form = FORM_UNFORMATTED;
2408 else
2409 u_flags.form = FORM_UNSPECIFIED;
2410
2411 u_flags.delim = DELIM_UNSPECIFIED;
2412 u_flags.blank = BLANK_UNSPECIFIED;
2413 u_flags.pad = PAD_UNSPECIFIED;
2414 u_flags.decimal = DECIMAL_UNSPECIFIED;
2415 u_flags.encoding = ENCODING_UNSPECIFIED;
2416 u_flags.async = ASYNC_UNSPECIFIED;
2417 u_flags.round = ROUND_UNSPECIFIED;
2418 u_flags.sign = SIGN_UNSPECIFIED;
2419
2420 u_flags.status = STATUS_UNKNOWN;
2421
2422 conv = get_unformatted_convert (dtp->common.unit);
2423
2424 if (conv == GFC_CONVERT_NONE)
2425 conv = compile_options.convert;
2426
2427 /* We use big_endian, which is 0 on little-endian machines
2428 and 1 on big-endian machines. */
2429 switch (conv)
2430 {
2431 case GFC_CONVERT_NATIVE:
2432 case GFC_CONVERT_SWAP:
2433 break;
2434
2435 case GFC_CONVERT_BIG:
2436 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
2437 break;
2438
2439 case GFC_CONVERT_LITTLE:
2440 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
2441 break;
2442
2443 default:
2444 internal_error (&opp.common, "Illegal value for CONVERT");
2445 break;
2446 }
2447
2448 u_flags.convert = conv;
2449
2450 opp.common = dtp->common;
2451 opp.common.flags &= IOPARM_COMMON_MASK;
2452 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
2453 dtp->common.flags &= ~IOPARM_COMMON_MASK;
2454 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
2455 if (dtp->u.p.current_unit == NULL)
2456 return;
2457 }
2458
2459 /* Check the action. */
2460
2461 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
2462 {
2463 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2464 "Cannot read from file opened for WRITE");
2465 return;
2466 }
2467
2468 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
2469 {
2470 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2471 "Cannot write to file opened for READ");
2472 return;
2473 }
2474
2475 dtp->u.p.first_item = 1;
2476
2477 /* Check the format. */
2478
2479 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2480 parse_format (dtp);
2481
2482 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
2483 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2484 != 0)
2485 {
2486 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2487 "Format present for UNFORMATTED data transfer");
2488 return;
2489 }
2490
2491 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
2492 {
2493 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2494 {
2495 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2496 "A format cannot be specified with a namelist");
2497 return;
2498 }
2499 }
2500 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
2501 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
2502 {
2503 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2504 "Missing format for FORMATTED data transfer");
2505 return;
2506 }
2507
2508 if (is_internal_unit (dtp)
2509 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2510 {
2511 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2512 "Internal file cannot be accessed by UNFORMATTED "
2513 "data transfer");
2514 return;
2515 }
2516
2517 /* Check the record or position number. */
2518
2519 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
2520 && (cf & IOPARM_DT_HAS_REC) == 0)
2521 {
2522 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2523 "Direct access data transfer requires record number");
2524 return;
2525 }
2526
2527 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2528 {
2529 if ((cf & IOPARM_DT_HAS_REC) != 0)
2530 {
2531 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2532 "Record number not allowed for sequential access "
2533 "data transfer");
2534 return;
2535 }
2536
2537 if (compile_options.warn_std &&
2538 dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
2539 {
2540 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2541 "Sequential READ or WRITE not allowed after "
2542 "EOF marker, possibly use REWIND or BACKSPACE");
2543 return;
2544 }
2545
2546 }
2547 /* Process the ADVANCE option. */
2548
2549 dtp->u.p.advance_status
2550 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
2551 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
2552 "Bad ADVANCE parameter in data transfer statement");
2553
2554 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
2555 {
2556 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2557 {
2558 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2559 "ADVANCE specification conflicts with sequential "
2560 "access");
2561 return;
2562 }
2563
2564 if (is_internal_unit (dtp))
2565 {
2566 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2567 "ADVANCE specification conflicts with internal file");
2568 return;
2569 }
2570
2571 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2572 != IOPARM_DT_HAS_FORMAT)
2573 {
2574 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2575 "ADVANCE specification requires an explicit format");
2576 return;
2577 }
2578 }
2579
2580 if (read_flag)
2581 {
2582 dtp->u.p.current_unit->previous_nonadvancing_write = 0;
2583
2584 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
2585 {
2586 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2587 "EOR specification requires an ADVANCE specification "
2588 "of NO");
2589 return;
2590 }
2591
2592 if ((cf & IOPARM_DT_HAS_SIZE) != 0
2593 && dtp->u.p.advance_status != ADVANCE_NO)
2594 {
2595 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2596 "SIZE specification requires an ADVANCE "
2597 "specification of NO");
2598 return;
2599 }
2600 }
2601 else
2602 { /* Write constraints. */
2603 if ((cf & IOPARM_END) != 0)
2604 {
2605 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2606 "END specification cannot appear in a write "
2607 "statement");
2608 return;
2609 }
2610
2611 if ((cf & IOPARM_EOR) != 0)
2612 {
2613 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2614 "EOR specification cannot appear in a write "
2615 "statement");
2616 return;
2617 }
2618
2619 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2620 {
2621 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2622 "SIZE specification cannot appear in a write "
2623 "statement");
2624 return;
2625 }
2626 }
2627
2628 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
2629 dtp->u.p.advance_status = ADVANCE_YES;
2630
2631 /* Check the decimal mode. */
2632 dtp->u.p.current_unit->decimal_status
2633 = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
2634 find_option (&dtp->common, dtp->decimal, dtp->decimal_len,
2635 decimal_opt, "Bad DECIMAL parameter in data transfer "
2636 "statement");
2637
2638 if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
2639 dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
2640
2641 /* Check the round mode. */
2642 dtp->u.p.current_unit->round_status
2643 = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
2644 find_option (&dtp->common, dtp->round, dtp->round_len,
2645 round_opt, "Bad ROUND parameter in data transfer "
2646 "statement");
2647
2648 if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
2649 dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
2650
2651 /* Check the sign mode. */
2652 dtp->u.p.sign_status
2653 = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
2654 find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
2655 "Bad SIGN parameter in data transfer statement");
2656
2657 if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
2658 dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
2659
2660 /* Check the blank mode. */
2661 dtp->u.p.blank_status
2662 = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
2663 find_option (&dtp->common, dtp->blank, dtp->blank_len,
2664 blank_opt,
2665 "Bad BLANK parameter in data transfer statement");
2666
2667 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
2668 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
2669
2670 /* Check the delim mode. */
2671 dtp->u.p.current_unit->delim_status
2672 = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
2673 find_option (&dtp->common, dtp->delim, dtp->delim_len,
2674 delim_opt, "Bad DELIM parameter in data transfer statement");
2675
2676 if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
2677 {
2678 if (ionml && dtp->u.p.current_unit->flags.delim == DELIM_UNSPECIFIED)
2679 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
2680 else
2681 dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
2682 }
2683
2684 /* Check the pad mode. */
2685 dtp->u.p.current_unit->pad_status
2686 = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
2687 find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
2688 "Bad PAD parameter in data transfer statement");
2689
2690 if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
2691 dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
2692
2693 /* Check to see if we might be reading what we wrote before */
2694
2695 if (dtp->u.p.mode != dtp->u.p.current_unit->mode
2696 && !is_internal_unit (dtp))
2697 {
2698 int pos = fbuf_reset (dtp->u.p.current_unit);
2699 if (pos != 0)
2700 sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
2701 sflush(dtp->u.p.current_unit->s);
2702 }
2703
2704 /* Check the POS= specifier: that it is in range and that it is used with a
2705 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2706
2707 if (((cf & IOPARM_DT_HAS_POS) != 0))
2708 {
2709 if (is_stream_io (dtp))
2710 {
2711
2712 if (dtp->pos <= 0)
2713 {
2714 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2715 "POS=specifier must be positive");
2716 return;
2717 }
2718
2719 if (dtp->pos >= dtp->u.p.current_unit->maxrec)
2720 {
2721 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2722 "POS=specifier too large");
2723 return;
2724 }
2725
2726 dtp->rec = dtp->pos;
2727
2728 if (dtp->u.p.mode == READING)
2729 {
2730 /* Reset the endfile flag; if we hit EOF during reading
2731 we'll set the flag and generate an error at that point
2732 rather than worrying about it here. */
2733 dtp->u.p.current_unit->endfile = NO_ENDFILE;
2734 }
2735
2736 if (dtp->pos != dtp->u.p.current_unit->strm_pos)
2737 {
2738 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
2739 if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
2740 {
2741 generate_error (&dtp->common, LIBERROR_OS, NULL);
2742 return;
2743 }
2744 dtp->u.p.current_unit->strm_pos = dtp->pos;
2745 }
2746 }
2747 else
2748 {
2749 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2750 "POS=specifier not allowed, "
2751 "Try OPEN with ACCESS='stream'");
2752 return;
2753 }
2754 }
2755
2756
2757 /* Sanity checks on the record number. */
2758 if ((cf & IOPARM_DT_HAS_REC) != 0)
2759 {
2760 if (dtp->rec <= 0)
2761 {
2762 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2763 "Record number must be positive");
2764 return;
2765 }
2766
2767 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
2768 {
2769 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2770 "Record number too large");
2771 return;
2772 }
2773
2774 /* Make sure format buffer is reset. */
2775 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2776 fbuf_reset (dtp->u.p.current_unit);
2777
2778
2779 /* Check whether the record exists to be read. Only
2780 a partial record needs to exist. */
2781
2782 if (dtp->u.p.mode == READING && (dtp->rec - 1)
2783 * dtp->u.p.current_unit->recl >= ssize (dtp->u.p.current_unit->s))
2784 {
2785 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2786 "Non-existing record number");
2787 return;
2788 }
2789
2790 /* Position the file. */
2791 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
2792 * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
2793 {
2794 generate_error (&dtp->common, LIBERROR_OS, NULL);
2795 return;
2796 }
2797
2798 /* TODO: This is required to maintain compatibility between
2799 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2800
2801 if (is_stream_io (dtp))
2802 dtp->u.p.current_unit->strm_pos = dtp->rec;
2803
2804 /* TODO: Un-comment this code when ABI changes from 4.3.
2805 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2806 {
2807 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2808 "Record number not allowed for stream access "
2809 "data transfer");
2810 return;
2811 } */
2812 }
2813
2814 /* Bugware for badly written mixed C-Fortran I/O. */
2815 if (!is_internal_unit (dtp))
2816 flush_if_preconnected(dtp->u.p.current_unit->s);
2817
2818 dtp->u.p.current_unit->mode = dtp->u.p.mode;
2819
2820 /* Set the maximum position reached from the previous I/O operation. This
2821 could be greater than zero from a previous non-advancing write. */
2822 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
2823
2824 pre_position (dtp);
2825
2826
2827 /* Set up the subroutine that will handle the transfers. */
2828
2829 if (read_flag)
2830 {
2831 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2832 dtp->u.p.transfer = unformatted_read;
2833 else
2834 {
2835 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2836 {
2837 dtp->u.p.last_char = EOF - 1;
2838 dtp->u.p.transfer = list_formatted_read;
2839 }
2840 else
2841 dtp->u.p.transfer = formatted_transfer;
2842 }
2843 }
2844 else
2845 {
2846 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2847 dtp->u.p.transfer = unformatted_write;
2848 else
2849 {
2850 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2851 dtp->u.p.transfer = list_formatted_write;
2852 else
2853 dtp->u.p.transfer = formatted_transfer;
2854 }
2855 }
2856
2857 /* Make sure that we don't do a read after a nonadvancing write. */
2858
2859 if (read_flag)
2860 {
2861 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
2862 {
2863 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2864 "Cannot READ after a nonadvancing WRITE");
2865 return;
2866 }
2867 }
2868 else
2869 {
2870 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2871 dtp->u.p.current_unit->read_bad = 1;
2872 }
2873
2874 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2875 {
2876 #ifdef HAVE_USELOCALE
2877 dtp->u.p.old_locale = uselocale (c_locale);
2878 #else
2879 __gthread_mutex_lock (&old_locale_lock);
2880 if (!old_locale_ctr++)
2881 {
2882 old_locale = setlocale (LC_NUMERIC, NULL);
2883 setlocale (LC_NUMERIC, "C");
2884 }
2885 __gthread_mutex_unlock (&old_locale_lock);
2886 #endif
2887 /* Start the data transfer if we are doing a formatted transfer. */
2888 if ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0
2889 && dtp->u.p.ionml == NULL)
2890 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2891 }
2892 }
2893
2894
2895 /* Initialize an array_loop_spec given the array descriptor. The function
2896 returns the index of the last element of the array, and also returns
2897 starting record, where the first I/O goes to (necessary in case of
2898 negative strides). */
2899
2900 gfc_offset
2901 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
2902 gfc_offset *start_record)
2903 {
2904 int rank = GFC_DESCRIPTOR_RANK(desc);
2905 int i;
2906 gfc_offset index;
2907 int empty;
2908
2909 empty = 0;
2910 index = 1;
2911 *start_record = 0;
2912
2913 for (i=0; i<rank; i++)
2914 {
2915 ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i);
2916 ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
2917 ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
2918 ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
2919 empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
2920 < GFC_DESCRIPTOR_LBOUND(desc,i));
2921
2922 if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
2923 {
2924 index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2925 * GFC_DESCRIPTOR_STRIDE(desc,i);
2926 }
2927 else
2928 {
2929 index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2930 * GFC_DESCRIPTOR_STRIDE(desc,i);
2931 *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2932 * GFC_DESCRIPTOR_STRIDE(desc,i);
2933 }
2934 }
2935
2936 if (empty)
2937 return 0;
2938 else
2939 return index;
2940 }
2941
2942 /* Determine the index to the next record in an internal unit array by
2943 by incrementing through the array_loop_spec. */
2944
2945 gfc_offset
2946 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
2947 {
2948 int i, carry;
2949 gfc_offset index;
2950
2951 carry = 1;
2952 index = 0;
2953
2954 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2955 {
2956 if (carry)
2957 {
2958 ls[i].idx++;
2959 if (ls[i].idx > ls[i].end)
2960 {
2961 ls[i].idx = ls[i].start;
2962 carry = 1;
2963 }
2964 else
2965 carry = 0;
2966 }
2967 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2968 }
2969
2970 *finished = carry;
2971
2972 return index;
2973 }
2974
2975
2976
2977 /* Skip to the end of the current record, taking care of an optional
2978 record marker of size bytes. If the file is not seekable, we
2979 read chunks of size MAX_READ until we get to the right
2980 position. */
2981
2982 static void
2983 skip_record (st_parameter_dt *dtp, ssize_t bytes)
2984 {
2985 ssize_t rlength, readb;
2986 #define MAX_READ 4096
2987 char p[MAX_READ];
2988
2989 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2990 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2991 return;
2992
2993 /* Direct access files do not generate END conditions,
2994 only I/O errors. */
2995 if (sseek (dtp->u.p.current_unit->s,
2996 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
2997 {
2998 /* Seeking failed, fall back to seeking by reading data. */
2999 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
3000 {
3001 rlength =
3002 (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
3003 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
3004
3005 readb = sread (dtp->u.p.current_unit->s, p, rlength);
3006 if (readb < 0)
3007 {
3008 generate_error (&dtp->common, LIBERROR_OS, NULL);
3009 return;
3010 }
3011
3012 dtp->u.p.current_unit->bytes_left_subrecord -= readb;
3013 }
3014 return;
3015 }
3016 dtp->u.p.current_unit->bytes_left_subrecord = 0;
3017 }
3018
3019
3020 /* Advance to the next record reading unformatted files, taking
3021 care of subrecords. If complete_record is nonzero, we loop
3022 until all subrecords are cleared. */
3023
3024 static void
3025 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
3026 {
3027 size_t bytes;
3028
3029 bytes = compile_options.record_marker == 0 ?
3030 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
3031
3032 while(1)
3033 {
3034
3035 /* Skip over tail */
3036
3037 skip_record (dtp, bytes);
3038
3039 if ( ! (complete_record && dtp->u.p.current_unit->continued))
3040 return;
3041
3042 us_read (dtp, 1);
3043 }
3044 }
3045
3046
3047 static gfc_offset
3048 min_off (gfc_offset a, gfc_offset b)
3049 {
3050 return (a < b ? a : b);
3051 }
3052
3053
3054 /* Space to the next record for read mode. */
3055
3056 static void
3057 next_record_r (st_parameter_dt *dtp, int done)
3058 {
3059 gfc_offset record;
3060 int bytes_left;
3061 char p;
3062 int cc;
3063
3064 switch (current_mode (dtp))
3065 {
3066 /* No records in unformatted STREAM I/O. */
3067 case UNFORMATTED_STREAM:
3068 return;
3069
3070 case UNFORMATTED_SEQUENTIAL:
3071 next_record_r_unf (dtp, 1);
3072 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3073 break;
3074
3075 case FORMATTED_DIRECT:
3076 case UNFORMATTED_DIRECT:
3077 skip_record (dtp, dtp->u.p.current_unit->bytes_left);
3078 break;
3079
3080 case FORMATTED_STREAM:
3081 case FORMATTED_SEQUENTIAL:
3082 /* read_sf has already terminated input because of an '\n', or
3083 we have hit EOF. */
3084 if (dtp->u.p.sf_seen_eor)
3085 {
3086 dtp->u.p.sf_seen_eor = 0;
3087 break;
3088 }
3089
3090 if (is_internal_unit (dtp))
3091 {
3092 if (is_array_io (dtp))
3093 {
3094 int finished;
3095
3096 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
3097 &finished);
3098 if (!done && finished)
3099 hit_eof (dtp);
3100
3101 /* Now seek to this record. */
3102 record = record * dtp->u.p.current_unit->recl;
3103 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
3104 {
3105 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3106 break;
3107 }
3108 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3109 }
3110 else
3111 {
3112 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
3113 bytes_left = min_off (bytes_left,
3114 ssize (dtp->u.p.current_unit->s)
3115 - stell (dtp->u.p.current_unit->s));
3116 if (sseek (dtp->u.p.current_unit->s,
3117 bytes_left, SEEK_CUR) < 0)
3118 {
3119 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3120 break;
3121 }
3122 dtp->u.p.current_unit->bytes_left
3123 = dtp->u.p.current_unit->recl;
3124 }
3125 break;
3126 }
3127 else
3128 {
3129 do
3130 {
3131 errno = 0;
3132 cc = fbuf_getc (dtp->u.p.current_unit);
3133 if (cc == EOF)
3134 {
3135 if (errno != 0)
3136 generate_error (&dtp->common, LIBERROR_OS, NULL);
3137 else
3138 {
3139 if (is_stream_io (dtp)
3140 || dtp->u.p.current_unit->pad_status == PAD_NO
3141 || dtp->u.p.current_unit->bytes_left
3142 == dtp->u.p.current_unit->recl)
3143 hit_eof (dtp);
3144 }
3145 break;
3146 }
3147
3148 if (is_stream_io (dtp))
3149 dtp->u.p.current_unit->strm_pos++;
3150
3151 p = (char) cc;
3152 }
3153 while (p != '\n');
3154 }
3155 break;
3156 }
3157 }
3158
3159
3160 /* Small utility function to write a record marker, taking care of
3161 byte swapping and of choosing the correct size. */
3162
3163 static int
3164 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
3165 {
3166 size_t len;
3167 GFC_INTEGER_4 buf4;
3168 GFC_INTEGER_8 buf8;
3169
3170 if (compile_options.record_marker == 0)
3171 len = sizeof (GFC_INTEGER_4);
3172 else
3173 len = compile_options.record_marker;
3174
3175 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3176 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
3177 {
3178 switch (len)
3179 {
3180 case sizeof (GFC_INTEGER_4):
3181 buf4 = buf;
3182 return swrite (dtp->u.p.current_unit->s, &buf4, len);
3183 break;
3184
3185 case sizeof (GFC_INTEGER_8):
3186 buf8 = buf;
3187 return swrite (dtp->u.p.current_unit->s, &buf8, len);
3188 break;
3189
3190 default:
3191 runtime_error ("Illegal value for record marker");
3192 break;
3193 }
3194 }
3195 else
3196 {
3197 uint32_t u32;
3198 uint64_t u64;
3199 switch (len)
3200 {
3201 case sizeof (GFC_INTEGER_4):
3202 buf4 = buf;
3203 memcpy (&u32, &buf4, sizeof (u32));
3204 u32 = __builtin_bswap32 (u32);
3205 return swrite (dtp->u.p.current_unit->s, &u32, len);
3206 break;
3207
3208 case sizeof (GFC_INTEGER_8):
3209 buf8 = buf;
3210 memcpy (&u64, &buf8, sizeof (u64));
3211 u64 = __builtin_bswap64 (u64);
3212 return swrite (dtp->u.p.current_unit->s, &u64, len);
3213 break;
3214
3215 default:
3216 runtime_error ("Illegal value for record marker");
3217 break;
3218 }
3219 }
3220
3221 }
3222
3223 /* Position to the next (sub)record in write mode for
3224 unformatted sequential files. */
3225
3226 static void
3227 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
3228 {
3229 gfc_offset m, m_write, record_marker;
3230
3231 /* Bytes written. */
3232 m = dtp->u.p.current_unit->recl_subrecord
3233 - dtp->u.p.current_unit->bytes_left_subrecord;
3234
3235 if (compile_options.record_marker == 0)
3236 record_marker = sizeof (GFC_INTEGER_4);
3237 else
3238 record_marker = compile_options.record_marker;
3239
3240 /* Seek to the head and overwrite the bogus length with the real
3241 length. */
3242
3243 if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
3244 SEEK_CUR) < 0))
3245 goto io_error;
3246
3247 if (next_subrecord)
3248 m_write = -m;
3249 else
3250 m_write = m;
3251
3252 if (unlikely (write_us_marker (dtp, m_write) < 0))
3253 goto io_error;
3254
3255 /* Seek past the end of the current record. */
3256
3257 if (unlikely (sseek (dtp->u.p.current_unit->s, m, SEEK_CUR) < 0))
3258 goto io_error;
3259
3260 /* Write the length tail. If we finish a record containing
3261 subrecords, we write out the negative length. */
3262
3263 if (dtp->u.p.current_unit->continued)
3264 m_write = -m;
3265 else
3266 m_write = m;
3267
3268 if (unlikely (write_us_marker (dtp, m_write) < 0))
3269 goto io_error;
3270
3271 return;
3272
3273 io_error:
3274 generate_error (&dtp->common, LIBERROR_OS, NULL);
3275 return;
3276
3277 }
3278
3279
3280 /* Utility function like memset() but operating on streams. Return
3281 value is same as for POSIX write(). */
3282
3283 static ssize_t
3284 sset (stream * s, int c, ssize_t nbyte)
3285 {
3286 #define WRITE_CHUNK 256
3287 char p[WRITE_CHUNK];
3288 ssize_t bytes_left, trans;
3289
3290 if (nbyte < WRITE_CHUNK)
3291 memset (p, c, nbyte);
3292 else
3293 memset (p, c, WRITE_CHUNK);
3294
3295 bytes_left = nbyte;
3296 while (bytes_left > 0)
3297 {
3298 trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
3299 trans = swrite (s, p, trans);
3300 if (trans <= 0)
3301 return trans;
3302 bytes_left -= trans;
3303 }
3304
3305 return nbyte - bytes_left;
3306 }
3307
3308
3309 /* Position to the next record in write mode. */
3310
3311 static void
3312 next_record_w (st_parameter_dt *dtp, int done)
3313 {
3314 gfc_offset m, record, max_pos;
3315 int length;
3316
3317 /* Zero counters for X- and T-editing. */
3318 max_pos = dtp->u.p.max_pos;
3319 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
3320
3321 switch (current_mode (dtp))
3322 {
3323 /* No records in unformatted STREAM I/O. */
3324 case UNFORMATTED_STREAM:
3325 return;
3326
3327 case FORMATTED_DIRECT:
3328 if (dtp->u.p.current_unit->bytes_left == 0)
3329 break;
3330
3331 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3332 fbuf_flush (dtp->u.p.current_unit, WRITING);
3333 if (sset (dtp->u.p.current_unit->s, ' ',
3334 dtp->u.p.current_unit->bytes_left)
3335 != dtp->u.p.current_unit->bytes_left)
3336 goto io_error;
3337
3338 break;
3339
3340 case UNFORMATTED_DIRECT:
3341 if (dtp->u.p.current_unit->bytes_left > 0)
3342 {
3343 length = (int) dtp->u.p.current_unit->bytes_left;
3344 if (sset (dtp->u.p.current_unit->s, 0, length) != length)
3345 goto io_error;
3346 }
3347 break;
3348
3349 case UNFORMATTED_SEQUENTIAL:
3350 next_record_w_unf (dtp, 0);
3351 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3352 break;
3353
3354 case FORMATTED_STREAM:
3355 case FORMATTED_SEQUENTIAL:
3356
3357 if (is_internal_unit (dtp))
3358 {
3359 char *p;
3360 if (is_array_io (dtp))
3361 {
3362 int finished;
3363
3364 length = (int) dtp->u.p.current_unit->bytes_left;
3365
3366 /* If the farthest position reached is greater than current
3367 position, adjust the position and set length to pad out
3368 whats left. Otherwise just pad whats left.
3369 (for character array unit) */
3370 m = dtp->u.p.current_unit->recl
3371 - dtp->u.p.current_unit->bytes_left;
3372 if (max_pos > m)
3373 {
3374 length = (int) (max_pos - m);
3375 if (sseek (dtp->u.p.current_unit->s,
3376 length, SEEK_CUR) < 0)
3377 {
3378 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3379 return;
3380 }
3381 length = (int) (dtp->u.p.current_unit->recl - max_pos);
3382 }
3383
3384 p = write_block (dtp, length);
3385 if (p == NULL)
3386 return;
3387
3388 if (unlikely (is_char4_unit (dtp)))
3389 {
3390 gfc_char4_t *p4 = (gfc_char4_t *) p;
3391 memset4 (p4, ' ', length);
3392 }
3393 else
3394 memset (p, ' ', length);
3395
3396 /* Now that the current record has been padded out,
3397 determine where the next record in the array is. */
3398 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
3399 &finished);
3400 if (finished)
3401 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3402
3403 /* Now seek to this record */
3404 record = record * dtp->u.p.current_unit->recl;
3405
3406 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
3407 {
3408 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3409 return;
3410 }
3411
3412 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3413 }
3414 else
3415 {
3416 length = 1;
3417
3418 /* If this is the last call to next_record move to the farthest
3419 position reached and set length to pad out the remainder
3420 of the record. (for character scaler unit) */
3421 if (done)
3422 {
3423 m = dtp->u.p.current_unit->recl
3424 - dtp->u.p.current_unit->bytes_left;
3425 if (max_pos > m)
3426 {
3427 length = (int) (max_pos - m);
3428 if (sseek (dtp->u.p.current_unit->s,
3429 length, SEEK_CUR) < 0)
3430 {
3431 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3432 return;
3433 }
3434 length = (int) (dtp->u.p.current_unit->recl - max_pos);
3435 }
3436 else
3437 length = (int) dtp->u.p.current_unit->bytes_left;
3438 }
3439 if (length > 0)
3440 {
3441 p = write_block (dtp, length);
3442 if (p == NULL)
3443 return;
3444
3445 if (unlikely (is_char4_unit (dtp)))
3446 {
3447 gfc_char4_t *p4 = (gfc_char4_t *) p;
3448 memset4 (p4, (gfc_char4_t) ' ', length);
3449 }
3450 else
3451 memset (p, ' ', length);
3452 }
3453 }
3454 }
3455 else
3456 {
3457 #ifdef HAVE_CRLF
3458 const int len = 2;
3459 #else
3460 const int len = 1;
3461 #endif
3462 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3463 char * p = fbuf_alloc (dtp->u.p.current_unit, len);
3464 if (!p)
3465 goto io_error;
3466 #ifdef HAVE_CRLF
3467 *(p++) = '\r';
3468 #endif
3469 *p = '\n';
3470 if (is_stream_io (dtp))
3471 {
3472 dtp->u.p.current_unit->strm_pos += len;
3473 if (dtp->u.p.current_unit->strm_pos
3474 < ssize (dtp->u.p.current_unit->s))
3475 unit_truncate (dtp->u.p.current_unit,
3476 dtp->u.p.current_unit->strm_pos - 1,
3477 &dtp->common);
3478 }
3479 }
3480
3481 break;
3482
3483 io_error:
3484 generate_error (&dtp->common, LIBERROR_OS, NULL);
3485 break;
3486 }
3487 }
3488
3489 /* Position to the next record, which means moving to the end of the
3490 current record. This can happen under several different
3491 conditions. If the done flag is not set, we get ready to process
3492 the next record. */
3493
3494 void
3495 next_record (st_parameter_dt *dtp, int done)
3496 {
3497 gfc_offset fp; /* File position. */
3498
3499 dtp->u.p.current_unit->read_bad = 0;
3500
3501 if (dtp->u.p.mode == READING)
3502 next_record_r (dtp, done);
3503 else
3504 next_record_w (dtp, done);
3505
3506 if (!is_stream_io (dtp))
3507 {
3508 /* Since we have changed the position, set it to unspecified so
3509 that INQUIRE(POSITION=) knows it needs to look into it. */
3510 if (done)
3511 dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED;
3512
3513 dtp->u.p.current_unit->current_record = 0;
3514 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
3515 {
3516 fp = stell (dtp->u.p.current_unit->s);
3517 /* Calculate next record, rounding up partial records. */
3518 dtp->u.p.current_unit->last_record =
3519 (fp + dtp->u.p.current_unit->recl - 1) /
3520 dtp->u.p.current_unit->recl;
3521 }
3522 else
3523 dtp->u.p.current_unit->last_record++;
3524 }
3525
3526 if (!done)
3527 pre_position (dtp);
3528
3529 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3530 smarkeor (dtp->u.p.current_unit->s);
3531 }
3532
3533
3534 /* Finalize the current data transfer. For a nonadvancing transfer,
3535 this means advancing to the next record. For internal units close the
3536 stream associated with the unit. */
3537
3538 static void
3539 finalize_transfer (st_parameter_dt *dtp)
3540 {
3541 GFC_INTEGER_4 cf = dtp->common.flags;
3542
3543 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
3544 *dtp->size = dtp->u.p.size_used;
3545
3546 if (dtp->u.p.eor_condition)
3547 {
3548 generate_error (&dtp->common, LIBERROR_EOR, NULL);
3549 goto done;
3550 }
3551
3552 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
3553 {
3554 if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
3555 dtp->u.p.current_unit->current_record = 0;
3556 goto done;
3557 }
3558
3559 if ((dtp->u.p.ionml != NULL)
3560 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
3561 {
3562 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
3563 namelist_read (dtp);
3564 else
3565 namelist_write (dtp);
3566 }
3567
3568 dtp->u.p.transfer = NULL;
3569 if (dtp->u.p.current_unit == NULL)
3570 goto done;
3571
3572 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
3573 {
3574 finish_list_read (dtp);
3575 goto done;
3576 }
3577
3578 if (dtp->u.p.mode == WRITING)
3579 dtp->u.p.current_unit->previous_nonadvancing_write
3580 = dtp->u.p.advance_status == ADVANCE_NO;
3581
3582 if (is_stream_io (dtp))
3583 {
3584 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3585 && dtp->u.p.advance_status != ADVANCE_NO)
3586 next_record (dtp, 1);
3587
3588 goto done;
3589 }
3590
3591 dtp->u.p.current_unit->current_record = 0;
3592
3593 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
3594 {
3595 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3596 dtp->u.p.seen_dollar = 0;
3597 goto done;
3598 }
3599
3600 /* For non-advancing I/O, save the current maximum position for use in the
3601 next I/O operation if needed. */
3602 if (dtp->u.p.advance_status == ADVANCE_NO)
3603 {
3604 if (dtp->u.p.skips > 0)
3605 {
3606 int tmp;
3607 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
3608 tmp = (int)(dtp->u.p.current_unit->recl
3609 - dtp->u.p.current_unit->bytes_left);
3610 dtp->u.p.max_pos =
3611 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
3612 dtp->u.p.skips = 0;
3613 }
3614 int bytes_written = (int) (dtp->u.p.current_unit->recl
3615 - dtp->u.p.current_unit->bytes_left);
3616 dtp->u.p.current_unit->saved_pos =
3617 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
3618 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3619 goto done;
3620 }
3621 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3622 && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
3623 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3624
3625 dtp->u.p.current_unit->saved_pos = 0;
3626
3627 next_record (dtp, 1);
3628
3629 done:
3630 #ifdef HAVE_USELOCALE
3631 if (dtp->u.p.old_locale != (locale_t) 0)
3632 {
3633 uselocale (dtp->u.p.old_locale);
3634 dtp->u.p.old_locale = (locale_t) 0;
3635 }
3636 #else
3637 __gthread_mutex_lock (&old_locale_lock);
3638 if (!--old_locale_ctr)
3639 {
3640 setlocale (LC_NUMERIC, old_locale);
3641 old_locale = NULL;
3642 }
3643 __gthread_mutex_unlock (&old_locale_lock);
3644 #endif
3645 }
3646
3647 /* Transfer function for IOLENGTH. It doesn't actually do any
3648 data transfer, it just updates the length counter. */
3649
3650 static void
3651 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
3652 void *dest __attribute__ ((unused)),
3653 int kind __attribute__((unused)),
3654 size_t size, size_t nelems)
3655 {
3656 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3657 *dtp->iolength += (GFC_IO_INT) (size * nelems);
3658 }
3659
3660
3661 /* Initialize the IOLENGTH data transfer. This function is in essence
3662 a very much simplified version of data_transfer_init(), because it
3663 doesn't have to deal with units at all. */
3664
3665 static void
3666 iolength_transfer_init (st_parameter_dt *dtp)
3667 {
3668 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3669 *dtp->iolength = 0;
3670
3671 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
3672
3673 /* Set up the subroutine that will handle the transfers. */
3674
3675 dtp->u.p.transfer = iolength_transfer;
3676 }
3677
3678
3679 /* Library entry point for the IOLENGTH form of the INQUIRE
3680 statement. The IOLENGTH form requires no I/O to be performed, but
3681 it must still be a runtime library call so that we can determine
3682 the iolength for dynamic arrays and such. */
3683
3684 extern void st_iolength (st_parameter_dt *);
3685 export_proto(st_iolength);
3686
3687 void
3688 st_iolength (st_parameter_dt *dtp)
3689 {
3690 library_start (&dtp->common);
3691 iolength_transfer_init (dtp);
3692 }
3693
3694 extern void st_iolength_done (st_parameter_dt *);
3695 export_proto(st_iolength_done);
3696
3697 void
3698 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
3699 {
3700 free_ionml (dtp);
3701 library_end ();
3702 }
3703
3704
3705 /* The READ statement. */
3706
3707 extern void st_read (st_parameter_dt *);
3708 export_proto(st_read);
3709
3710 void
3711 st_read (st_parameter_dt *dtp)
3712 {
3713 library_start (&dtp->common);
3714
3715 data_transfer_init (dtp, 1);
3716 }
3717
3718 extern void st_read_done (st_parameter_dt *);
3719 export_proto(st_read_done);
3720
3721 void
3722 st_read_done (st_parameter_dt *dtp)
3723 {
3724 finalize_transfer (dtp);
3725
3726 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3727 {
3728 free_format_data (dtp->u.p.fmt);
3729 free_format (dtp);
3730 }
3731
3732 free_ionml (dtp);
3733
3734 if (dtp->u.p.current_unit != NULL)
3735 unlock_unit (dtp->u.p.current_unit);
3736
3737 free_internal_unit (dtp);
3738
3739 library_end ();
3740 }
3741
3742 extern void st_write (st_parameter_dt *);
3743 export_proto(st_write);
3744
3745 void
3746 st_write (st_parameter_dt *dtp)
3747 {
3748 library_start (&dtp->common);
3749 data_transfer_init (dtp, 0);
3750 }
3751
3752 extern void st_write_done (st_parameter_dt *);
3753 export_proto(st_write_done);
3754
3755 void
3756 st_write_done (st_parameter_dt *dtp)
3757 {
3758 finalize_transfer (dtp);
3759
3760 /* Deal with endfile conditions associated with sequential files. */
3761
3762 if (dtp->u.p.current_unit != NULL
3763 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3764 switch (dtp->u.p.current_unit->endfile)
3765 {
3766 case AT_ENDFILE: /* Remain at the endfile record. */
3767 break;
3768
3769 case AFTER_ENDFILE:
3770 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
3771 break;
3772
3773 case NO_ENDFILE:
3774 /* Get rid of whatever is after this record. */
3775 if (!is_internal_unit (dtp))
3776 unit_truncate (dtp->u.p.current_unit,
3777 stell (dtp->u.p.current_unit->s),
3778 &dtp->common);
3779 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3780 break;
3781 }
3782
3783 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3784 {
3785 free_format_data (dtp->u.p.fmt);
3786 free_format (dtp);
3787 }
3788
3789 free_ionml (dtp);
3790
3791 if (dtp->u.p.current_unit != NULL)
3792 unlock_unit (dtp->u.p.current_unit);
3793
3794 free_internal_unit (dtp);
3795
3796 library_end ();
3797 }
3798
3799
3800 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3801 void
3802 st_wait (st_parameter_wait *wtp __attribute__((unused)))
3803 {
3804 }
3805
3806
3807 /* Receives the scalar information for namelist objects and stores it
3808 in a linked list of namelist_info types. */
3809
3810 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
3811 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
3812 export_proto(st_set_nml_var);
3813
3814
3815 void
3816 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
3817 GFC_INTEGER_4 len, gfc_charlen_type string_length,
3818 GFC_INTEGER_4 dtype)
3819 {
3820 namelist_info *t1 = NULL;
3821 namelist_info *nml;
3822 size_t var_name_len = strlen (var_name);
3823
3824 nml = (namelist_info*) xmalloc (sizeof (namelist_info));
3825
3826 nml->mem_pos = var_addr;
3827
3828 nml->var_name = (char*) xmalloc (var_name_len + 1);
3829 memcpy (nml->var_name, var_name, var_name_len);
3830 nml->var_name[var_name_len] = '\0';
3831
3832 nml->len = (int) len;
3833 nml->string_length = (index_type) string_length;
3834
3835 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
3836 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
3837 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
3838
3839 if (nml->var_rank > 0)
3840 {
3841 nml->dim = (descriptor_dimension*)
3842 xmallocarray (nml->var_rank, sizeof (descriptor_dimension));
3843 nml->ls = (array_loop_spec*)
3844 xmallocarray (nml->var_rank, sizeof (array_loop_spec));
3845 }
3846 else
3847 {
3848 nml->dim = NULL;
3849 nml->ls = NULL;
3850 }
3851
3852 nml->next = NULL;
3853
3854 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
3855 {
3856 dtp->common.flags |= IOPARM_DT_IONML_SET;
3857 dtp->u.p.ionml = nml;
3858 }
3859 else
3860 {
3861 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
3862 t1->next = nml;
3863 }
3864 }
3865
3866 /* Store the dimensional information for the namelist object. */
3867 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
3868 index_type, index_type,
3869 index_type);
3870 export_proto(st_set_nml_var_dim);
3871
3872 void
3873 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
3874 index_type stride, index_type lbound,
3875 index_type ubound)
3876 {
3877 namelist_info * nml;
3878 int n;
3879
3880 n = (int)n_dim;
3881
3882 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
3883
3884 GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
3885 }
3886
3887
3888 /* Once upon a time, a poor innocent Fortran program was reading a
3889 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3890 the OS doesn't tell whether we're at the EOF or whether we already
3891 went past it. Luckily our hero, libgfortran, keeps track of this.
3892 Call this function when you detect an EOF condition. See Section
3893 9.10.2 in F2003. */
3894
3895 void
3896 hit_eof (st_parameter_dt * dtp)
3897 {
3898 dtp->u.p.current_unit->flags.position = POSITION_APPEND;
3899
3900 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3901 switch (dtp->u.p.current_unit->endfile)
3902 {
3903 case NO_ENDFILE:
3904 case AT_ENDFILE:
3905 generate_error (&dtp->common, LIBERROR_END, NULL);
3906 if (!is_internal_unit (dtp) && !dtp->u.p.namelist_mode)
3907 {
3908 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
3909 dtp->u.p.current_unit->current_record = 0;
3910 }
3911 else
3912 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3913 break;
3914
3915 case AFTER_ENDFILE:
3916 generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
3917 dtp->u.p.current_unit->current_record = 0;
3918 break;
3919 }
3920 else
3921 {
3922 /* Non-sequential files don't have an ENDFILE record, so we
3923 can't be at AFTER_ENDFILE. */
3924 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3925 generate_error (&dtp->common, LIBERROR_END, NULL);
3926 dtp->u.p.current_unit->current_record = 0;
3927 }
3928 }