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