OSDN Git Service

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