OSDN Git Service

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