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