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