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