OSDN Git Service

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