OSDN Git Service

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