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