OSDN Git Service

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