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