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