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