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