OSDN Git Service

2006-08-15 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / transfer.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3    Namelist transfer functions contributed by Paul Thomas
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file.  (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
20
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24 GNU General Public License for more details.
25
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING.  If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA.  */
30
31
32 /* transfer.c -- Top level handling of data transfer statements.  */
33
34 #include "config.h"
35 #include <string.h>
36 #include <assert.h>
37 #include "libgfortran.h"
38 #include "io.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_real
57       transfer_complex
58
59     These subroutines do not return status.
60
61     The last call is a call to st_[read|write]_done().  While
62     something can easily go wrong with the initial st_read() or
63     st_write(), an error inhibits any data from actually being
64     transferred.  */
65
66 extern void transfer_integer (st_parameter_dt *, void *, int);
67 export_proto(transfer_integer);
68
69 extern void transfer_real (st_parameter_dt *, void *, int);
70 export_proto(transfer_real);
71
72 extern void transfer_logical (st_parameter_dt *, void *, int);
73 export_proto(transfer_logical);
74
75 extern void transfer_character (st_parameter_dt *, void *, int);
76 export_proto(transfer_character);
77
78 extern void transfer_complex (st_parameter_dt *, void *, int);
79 export_proto(transfer_complex);
80
81 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
82                             gfc_charlen_type);
83 export_proto(transfer_array);
84
85 static const st_option advance_opt[] = {
86   {"yes", ADVANCE_YES},
87   {"no", ADVANCE_NO},
88   {NULL, 0}
89 };
90
91
92 typedef enum
93 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
94   FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
95 }
96 file_mode;
97
98
99 static file_mode
100 current_mode (st_parameter_dt *dtp)
101 {
102   file_mode m;
103
104   m = FORM_UNSPECIFIED;
105
106   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
107     {
108       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
109         FORMATTED_DIRECT : UNFORMATTED_DIRECT;
110     }
111   else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
112     {
113       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
114         FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
115     }
116   else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
117     {
118       m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
119         FORMATTED_STREAM : UNFORMATTED_STREAM;
120     }
121
122   return m;
123 }
124
125
126 /* Mid level data transfer statements.  These subroutines do reading
127    and writing in the style of salloc_r()/salloc_w() within the
128    current record.  */
129
130 /* When reading sequential formatted records we have a problem.  We
131    don't know how long the line is until we read the trailing newline,
132    and we don't want to read too much.  If we read too much, we might
133    have to do a physical seek backwards depending on how much data is
134    present, and devices like terminals aren't seekable and would cause
135    an I/O error.
136
137    Given this, the solution is to read a byte at a time, stopping if
138    we hit the newline.  For small allocations, we use a static buffer.
139    For larger allocations, we are forced to allocate memory on the
140    heap.  Hopefully this won't happen very often.  */
141
142 char *
143 read_sf (st_parameter_dt *dtp, int *length, int no_error)
144 {
145   char *base, *p, *q;
146   int n, readlen, crlf;
147   gfc_offset pos;
148
149   if (*length > SCRATCH_SIZE)
150     dtp->u.p.line_buffer = get_mem (*length);
151   p = base = dtp->u.p.line_buffer;
152
153   /* If we have seen an eor previously, return a length of 0.  The
154      caller is responsible for correctly padding the input field.  */
155   if (dtp->u.p.sf_seen_eor)
156     {
157       *length = 0;
158       return base;
159     }
160
161   readlen = 1;
162   n = 0;
163
164   do
165     {
166       if (is_internal_unit (dtp))
167         {
168           /* readlen may be modified inside salloc_r if
169              is_internal_unit (dtp) is true.  */
170           readlen = 1;
171         }
172
173       q = salloc_r (dtp->u.p.current_unit->s, &readlen);
174       if (q == NULL)
175         break;
176
177       /* If we have a line without a terminating \n, drop through to
178          EOR below.  */
179       if (readlen < 1 && n == 0)
180         {
181           if (no_error)
182             break;
183           generate_error (&dtp->common, ERROR_END, NULL);
184           return NULL;
185         }
186
187       if (readlen < 1 || *q == '\n' || *q == '\r')
188         {
189           /* Unexpected end of line.  */
190
191           /* If we see an EOR during non-advancing I/O, we need to skip
192              the rest of the I/O statement.  Set the corresponding flag.  */
193           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
194             dtp->u.p.eor_condition = 1;
195
196           crlf = 0;
197           /* If we encounter a CR, it might be a CRLF.  */
198           if (*q == '\r') /* Probably a CRLF */
199             {
200               readlen = 1;
201               pos = stream_offset (dtp->u.p.current_unit->s);
202               q = salloc_r (dtp->u.p.current_unit->s, &readlen);
203               if (*q != '\n' && readlen == 1) /* Not a CRLF after all.  */
204                 sseek (dtp->u.p.current_unit->s, pos);
205               else
206                 crlf = 1;
207             }
208
209           /* Without padding, terminate the I/O statement without assigning
210              the value.  With padding, the value still needs to be assigned,
211              so we can just continue with a short read.  */
212           if (dtp->u.p.current_unit->flags.pad == PAD_NO)
213             {
214               if (no_error)
215                 break;
216               generate_error (&dtp->common, ERROR_EOR, NULL);
217               return NULL;
218             }
219
220           *length = n;
221           dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
222           break;
223         }
224       /*  Short circuit the read if a comma is found during numeric input.
225           The flag is set to zero during character reads so that commas in
226           strings are not ignored  */
227       if (*q == ',')
228         if (dtp->u.p.sf_read_comma == 1)
229           {
230             notify_std (&dtp->common, GFC_STD_GNU,
231                         "Comma in formatted numeric read.");
232             *length = n;
233             break;
234           }
235
236       n++;
237       *p++ = *q;
238       dtp->u.p.sf_seen_eor = 0;
239     }
240   while (n < *length);
241   dtp->u.p.current_unit->bytes_left -= *length;
242
243   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
244     dtp->u.p.size_used += (gfc_offset) *length;
245
246   return base;
247 }
248
249
250 /* Function for reading the next couple of bytes from the current
251    file, advancing the current position.  We return a pointer to a
252    buffer containing the bytes.  We return NULL on end of record or
253    end of file.
254
255    If the read is short, then it is because the current record does not
256    have enough data to satisfy the read request and the file was
257    opened with PAD=YES.  The caller must assume tailing spaces for
258    short reads.  */
259
260 void *
261 read_block (st_parameter_dt *dtp, int *length)
262 {
263   char *source;
264   int nread;
265
266   if (!is_stream_io (dtp))
267     {
268       if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
269         {
270           /* For preconnected units with default record length, set bytes left
271            to unit record length and proceed, otherwise error.  */
272           if (dtp->u.p.current_unit->unit_number == options.stdin_unit
273               && dtp->u.p.current_unit->recl == DEFAULT_RECL)
274           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
275           else
276             {
277               if (dtp->u.p.current_unit->flags.pad == PAD_NO)
278                 {
279                   /* Not enough data left.  */
280                   generate_error (&dtp->common, ERROR_EOR, NULL);
281                   return NULL;
282                 }
283             }
284
285           if (dtp->u.p.current_unit->bytes_left == 0)
286             {
287               dtp->u.p.current_unit->endfile = AT_ENDFILE;
288               generate_error (&dtp->common, ERROR_END, NULL);
289               return NULL;
290             }
291
292           *length = dtp->u.p.current_unit->bytes_left;
293         }
294
295       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
296         dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
297           return read_sf (dtp, length, 0);      /* Special case.  */
298
299       dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
300
301       nread = *length;
302       source = salloc_r (dtp->u.p.current_unit->s, &nread);
303
304       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
305         dtp->u.p.size_used += (gfc_offset) nread;
306
307       if (nread != *length)
308         {                               /* Short read, this shouldn't happen.  */
309           if (dtp->u.p.current_unit->flags.pad == PAD_YES)
310             *length = nread;
311           else
312             {
313               generate_error (&dtp->common, ERROR_EOR, NULL);
314               source = NULL;
315             }
316         }
317     }
318   else
319     {
320       if (sseek (dtp->u.p.current_unit->s,
321                  (gfc_offset) (dtp->rec - 1)) == FAILURE)
322         {
323           generate_error (&dtp->common, ERROR_END, NULL);
324           return NULL;
325         }
326
327       nread = *length;
328       source = salloc_r (dtp->u.p.current_unit->s, &nread);
329
330       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
331         dtp->u.p.size_used += (gfc_offset) nread;
332
333       if (nread != *length)
334         {                               /* Short read, this shouldn't happen.  */
335           if (dtp->u.p.current_unit->flags.pad == PAD_YES)
336             *length = nread;
337           else
338             {
339               generate_error (&dtp->common, ERROR_END, NULL);
340               source = NULL;
341             }
342         }
343
344       dtp->rec += (GFC_IO_INT) nread;
345     }
346   return source;
347 }
348
349
350 /* Reads a block directly into application data space.  */
351
352 static void
353 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
354 {
355   int *length;
356   void *data;
357   size_t nread;
358
359   if (!is_stream_io (dtp))
360     {
361       if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
362         {
363           /* For preconnected units with default record length, set
364              bytes left to unit record length and proceed, otherwise
365              error.  */
366           if (dtp->u.p.current_unit->unit_number == options.stdin_unit
367               && dtp->u.p.current_unit->recl == DEFAULT_RECL)
368             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
369           else
370             {
371               if (dtp->u.p.current_unit->flags.pad == PAD_NO)
372                 {
373                   /* Not enough data left.  */
374                   generate_error (&dtp->common, ERROR_EOR, NULL);
375                   return;
376                 }
377             }
378           
379           if (dtp->u.p.current_unit->bytes_left == 0)
380             {
381               dtp->u.p.current_unit->endfile = AT_ENDFILE;
382               generate_error (&dtp->common, ERROR_END, NULL);
383               return;
384             }
385
386           *nbytes = (size_t) dtp->u.p.current_unit->bytes_left;
387         }
388
389       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
390           dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
391         {
392           length = (int *) nbytes;
393           data = read_sf (dtp, length, 0);      /* Special case.  */
394           memcpy (buf, data, (size_t) *length);
395           return;
396         }
397
398       dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
399     }
400   else
401     {
402       if (sseek (dtp->u.p.current_unit->s,
403           (gfc_offset) (dtp->rec - 1)) == FAILURE)
404         {
405           generate_error (&dtp->common, ERROR_END, NULL);
406           return;
407         }
408     }
409
410   nread = *nbytes;
411   if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
412     {
413       generate_error (&dtp->common, ERROR_OS, NULL);
414       return;
415     }
416
417   if (!is_stream_io (dtp))
418     {
419       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
420         dtp->u.p.size_used += (gfc_offset) nread;
421     }
422   else
423     dtp->rec += (GFC_IO_INT) nread; 
424
425   if (nread != *nbytes)  /* Short read, e.g. if we hit EOF.  */
426     {
427       if (!is_stream_io (dtp))
428         generate_error (&dtp->common, ERROR_EOR, NULL);
429       else
430         generate_error (&dtp->common, ERROR_END, NULL);   
431     }
432 }
433
434
435 /* Function for writing a block of bytes to the current file at the
436    current position, advancing the file pointer. We are given a length
437    and return a pointer to a buffer that the caller must (completely)
438    fill in.  Returns NULL on error.  */
439
440 void *
441 write_block (st_parameter_dt *dtp, int length)
442 {
443   char *dest;
444
445   if (!is_stream_io (dtp))
446     {
447       if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
448         {
449           /* For preconnected units with default record length, set bytes left
450              to unit record length and proceed, otherwise error.  */
451           if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
452                 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
453                 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
454             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
455           else
456             {
457               generate_error (&dtp->common, ERROR_EOR, NULL);
458               return NULL;
459             }
460         }
461
462       dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
463
464
465       dest = salloc_w (dtp->u.p.current_unit->s, &length);
466   
467       if (dest == NULL)
468         {
469           generate_error (&dtp->common, ERROR_END, NULL);
470           return NULL;
471         }
472
473       if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
474         generate_error (&dtp->common, ERROR_END, NULL);
475
476       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
477         dtp->u.p.size_used += (gfc_offset) length;
478     }
479   else
480     {
481       if (sseek (dtp->u.p.current_unit->s,
482           (gfc_offset) (dtp->rec - 1)) == FAILURE)
483         {
484           generate_error (&dtp->common, ERROR_END, NULL);
485           return NULL;
486         }
487
488       dest = salloc_w (dtp->u.p.current_unit->s, &length);
489
490       if (dest == NULL)
491         {
492           generate_error (&dtp->common, ERROR_END, NULL);
493           return NULL;
494         }
495
496       dtp->rec += (GFC_IO_INT) length;
497     }
498
499   return dest;
500 }
501
502
503 /* High level interface to swrite(), taking care of errors.  */
504
505 static try
506 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
507 {
508   if (!is_stream_io (dtp))
509     {
510       if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
511         {
512           /* For preconnected units with default record length, set
513              bytes left to unit record length and proceed, otherwise
514              error.  */
515           if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
516                || dtp->u.p.current_unit->unit_number == options.stderr_unit)
517               && dtp->u.p.current_unit->recl == DEFAULT_RECL)
518             dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
519           else
520             {
521               if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
522                 generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
523               else
524                 generate_error (&dtp->common, ERROR_EOR, NULL);
525               return FAILURE;
526             }
527         }
528
529       dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
530     }
531   else
532     {
533       if (sseek (dtp->u.p.current_unit->s,
534                  (gfc_offset) (dtp->rec - 1)) == FAILURE)
535         {
536           generate_error (&dtp->common, ERROR_OS, NULL);
537           return FAILURE;
538         }
539     }
540
541   if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
542     {
543       generate_error (&dtp->common, ERROR_OS, NULL);
544       return FAILURE;
545     }
546
547   if (!is_stream_io (dtp))
548     {
549       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
550         dtp->u.p.size_used += (gfc_offset) nbytes;
551     }
552   else
553     dtp->rec += (GFC_IO_INT) nbytes; 
554
555   return SUCCESS;
556 }
557
558
559 /* Master function for unformatted reads.  */
560
561 static void
562 unformatted_read (st_parameter_dt *dtp, bt type,
563                   void *dest, int kind,
564                   size_t size, size_t nelems)
565 {
566   size_t i, sz;
567
568   /* Currently, character implies size=1.  */
569   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
570       || size == 1 || type == BT_CHARACTER)
571     {
572       sz = size * nelems;
573       read_block_direct (dtp, dest, &sz);
574     }
575   else
576     {
577       char buffer[16];
578       char *p;
579       
580       /* Break up complex into its constituent reals.  */
581       if (type == BT_COMPLEX)
582         {
583           nelems *= 2;
584           size /= 2;
585         }
586       p = dest;
587       
588       /* By now, all complex variables have been split into their
589          constituent reals.  For types with padding, we only need to
590          read kind bytes.  We don't care about the contents
591          of the padding.  */
592       
593       sz = kind;
594       for (i=0; i<nelems; i++)
595         {
596           read_block_direct (dtp, buffer, &sz);
597           reverse_memcpy (p, buffer, sz);
598           p += size;
599         }
600     }
601 }
602
603
604 /* Master function for unformatted writes.  */
605
606 static void
607 unformatted_write (st_parameter_dt *dtp, bt type,
608                    void *source, int kind,
609                    size_t size, size_t nelems)
610 {
611   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
612       size == 1 || type == BT_CHARACTER)
613     {
614       size *= nelems;
615
616       write_buf (dtp, source, size);
617     }
618   else
619     {
620       char buffer[16];
621       char *p;
622       size_t i, sz;
623   
624       /* Break up complex into its constituent reals.  */
625       if (type == BT_COMPLEX)
626         {
627           nelems *= 2;
628           size /= 2;
629         }      
630
631       p = source;
632
633       /* By now, all complex variables have been split into their
634          constituent reals.  For types with padding, we only need to
635          read kind bytes.  We don't care about the contents
636          of the padding.  */
637
638       sz = kind;
639       for (i=0; i<nelems; i++)
640         {
641           reverse_memcpy(buffer, p, size);
642           p+= size;
643           write_buf (dtp, buffer, sz);
644         }
645     }
646 }
647
648
649 /* Return a pointer to the name of a type.  */
650
651 const char *
652 type_name (bt type)
653 {
654   const char *p;
655
656   switch (type)
657     {
658     case BT_INTEGER:
659       p = "INTEGER";
660       break;
661     case BT_LOGICAL:
662       p = "LOGICAL";
663       break;
664     case BT_CHARACTER:
665       p = "CHARACTER";
666       break;
667     case BT_REAL:
668       p = "REAL";
669       break;
670     case BT_COMPLEX:
671       p = "COMPLEX";
672       break;
673     default:
674       internal_error (NULL, "type_name(): Bad type");
675     }
676
677   return p;
678 }
679
680
681 /* Write a constant string to the output.
682    This is complicated because the string can have doubled delimiters
683    in it.  The length in the format node is the true length.  */
684
685 static void
686 write_constant_string (st_parameter_dt *dtp, const fnode *f)
687 {
688   char c, delimiter, *p, *q;
689   int length;
690
691   length = f->u.string.length;
692   if (length == 0)
693     return;
694
695   p = write_block (dtp, length);
696   if (p == NULL)
697     return;
698
699   q = f->u.string.p;
700   delimiter = q[-1];
701
702   for (; length > 0; length--)
703     {
704       c = *p++ = *q++;
705       if (c == delimiter && c != 'H' && c != 'h')
706         q++;                    /* Skip the doubled delimiter.  */
707     }
708 }
709
710
711 /* Given actual and expected types in a formatted data transfer, make
712    sure they agree.  If not, an error message is generated.  Returns
713    nonzero if something went wrong.  */
714
715 static int
716 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
717 {
718   char buffer[100];
719
720   if (actual == expected)
721     return 0;
722
723   st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
724               type_name (expected), dtp->u.p.item_count, type_name (actual));
725
726   format_error (dtp, f, buffer);
727   return 1;
728 }
729
730
731 /* This subroutine is the main loop for a formatted data transfer
732    statement.  It would be natural to implement this as a coroutine
733    with the user program, but C makes that awkward.  We loop,
734    processesing format elements.  When we actually have to transfer
735    data instead of just setting flags, we return control to the user
736    program which calls a subroutine that supplies the address and type
737    of the next element, then comes back here to process it.  */
738
739 static void
740 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
741                            size_t size)
742 {
743   char scratch[SCRATCH_SIZE];
744   int pos, bytes_used;
745   const fnode *f;
746   format_token t;
747   int n;
748   int consume_data_flag;
749
750   /* Change a complex data item into a pair of reals.  */
751
752   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
753   if (type == BT_COMPLEX)
754     {
755       type = BT_REAL;
756       size /= 2;
757     }
758
759   /* If there's an EOR condition, we simulate finalizing the transfer
760      by doing nothing.  */
761   if (dtp->u.p.eor_condition)
762     return;
763
764   /* Set this flag so that commas in reads cause the read to complete before
765      the entire field has been read.  The next read field will start right after
766      the comma in the stream.  (Set to 0 for character reads).  */
767   dtp->u.p.sf_read_comma = 1;
768
769   dtp->u.p.line_buffer = scratch;
770   for (;;)
771     {
772       /* If reversion has occurred and there is another real data item,
773          then we have to move to the next record.  */
774       if (dtp->u.p.reversion_flag && n > 0)
775         {
776           dtp->u.p.reversion_flag = 0;
777           next_record (dtp, 0);
778         }
779
780       consume_data_flag = 1 ;
781       if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
782         break;
783
784       f = next_format (dtp);
785       if (f == NULL)
786         {
787           /* No data descriptors left.  */
788           if (n > 0)
789             generate_error (&dtp->common, ERROR_FORMAT,
790                 "Insufficient data descriptors in format after reversion");
791           return;
792         }
793
794       /* Now discharge T, TR and X movements to the right.  This is delayed
795          until a data producing format to suppress trailing spaces.  */
796          
797       t = f->format;
798       if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
799         && ((n>0 && (  t == FMT_I  || t == FMT_B  || t == FMT_O
800                     || t == FMT_Z  || t == FMT_F  || t == FMT_E
801                     || t == FMT_EN || t == FMT_ES || t == FMT_G
802                     || t == FMT_L  || t == FMT_A  || t == FMT_D))
803             || t == FMT_STRING))
804         {
805           if (dtp->u.p.skips > 0)
806             {
807               write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
808               dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
809                                        - dtp->u.p.current_unit->bytes_left);
810             }
811           if (dtp->u.p.skips < 0)
812             {
813               move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
814               dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
815             }
816           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
817         }
818
819       bytes_used = (int)(dtp->u.p.current_unit->recl
820                          - dtp->u.p.current_unit->bytes_left);
821
822       switch (t)
823         {
824         case FMT_I:
825           if (n == 0)
826             goto need_data;
827           if (require_type (dtp, BT_INTEGER, type, f))
828             return;
829
830           if (dtp->u.p.mode == READING)
831             read_decimal (dtp, f, p, len);
832           else
833             write_i (dtp, f, p, len);
834
835           break;
836
837         case FMT_B:
838           if (n == 0)
839             goto need_data;
840           if (require_type (dtp, BT_INTEGER, type, f))
841             return;
842
843           if (dtp->u.p.mode == READING)
844             read_radix (dtp, f, p, len, 2);
845           else
846             write_b (dtp, f, p, len);
847
848           break;
849
850         case FMT_O:
851           if (n == 0)
852             goto need_data;
853
854           if (dtp->u.p.mode == READING)
855             read_radix (dtp, f, p, len, 8);
856           else
857             write_o (dtp, f, p, len);
858
859           break;
860
861         case FMT_Z:
862           if (n == 0)
863             goto need_data;
864
865           if (dtp->u.p.mode == READING)
866             read_radix (dtp, f, p, len, 16);
867           else
868             write_z (dtp, f, p, len);
869
870           break;
871
872         case FMT_A:
873           if (n == 0)
874             goto need_data;
875
876           if (dtp->u.p.mode == READING)
877             read_a (dtp, f, p, len);
878           else
879             write_a (dtp, f, p, len);
880
881           break;
882
883         case FMT_L:
884           if (n == 0)
885             goto need_data;
886
887           if (dtp->u.p.mode == READING)
888             read_l (dtp, f, p, len);
889           else
890             write_l (dtp, f, p, len);
891
892           break;
893
894         case FMT_D:
895           if (n == 0)
896             goto need_data;
897           if (require_type (dtp, BT_REAL, type, f))
898             return;
899
900           if (dtp->u.p.mode == READING)
901             read_f (dtp, f, p, len);
902           else
903             write_d (dtp, f, p, len);
904
905           break;
906
907         case FMT_E:
908           if (n == 0)
909             goto need_data;
910           if (require_type (dtp, BT_REAL, type, f))
911             return;
912
913           if (dtp->u.p.mode == READING)
914             read_f (dtp, f, p, len);
915           else
916             write_e (dtp, f, p, len);
917           break;
918
919         case FMT_EN:
920           if (n == 0)
921             goto need_data;
922           if (require_type (dtp, BT_REAL, type, f))
923             return;
924
925           if (dtp->u.p.mode == READING)
926             read_f (dtp, f, p, len);
927           else
928             write_en (dtp, f, p, len);
929
930           break;
931
932         case FMT_ES:
933           if (n == 0)
934             goto need_data;
935           if (require_type (dtp, BT_REAL, type, f))
936             return;
937
938           if (dtp->u.p.mode == READING)
939             read_f (dtp, f, p, len);
940           else
941             write_es (dtp, f, p, len);
942
943           break;
944
945         case FMT_F:
946           if (n == 0)
947             goto need_data;
948           if (require_type (dtp, BT_REAL, type, f))
949             return;
950
951           if (dtp->u.p.mode == READING)
952             read_f (dtp, f, p, len);
953           else
954             write_f (dtp, f, p, len);
955
956           break;
957
958         case FMT_G:
959           if (n == 0)
960             goto need_data;
961           if (dtp->u.p.mode == READING)
962             switch (type)
963               {
964               case BT_INTEGER:
965                 read_decimal (dtp, f, p, len);
966                 break;
967               case BT_LOGICAL:
968                 read_l (dtp, f, p, len);
969                 break;
970               case BT_CHARACTER:
971                 read_a (dtp, f, p, len);
972                 break;
973               case BT_REAL:
974                 read_f (dtp, f, p, len);
975                 break;
976               default:
977                 goto bad_type;
978               }
979           else
980             switch (type)
981               {
982               case BT_INTEGER:
983                 write_i (dtp, f, p, len);
984                 break;
985               case BT_LOGICAL:
986                 write_l (dtp, f, p, len);
987                 break;
988               case BT_CHARACTER:
989                 write_a (dtp, f, p, len);
990                 break;
991               case BT_REAL:
992                 write_d (dtp, f, p, len);
993                 break;
994               default:
995               bad_type:
996                 internal_error (&dtp->common,
997                                 "formatted_transfer(): Bad type");
998               }
999
1000           break;
1001
1002         case FMT_STRING:
1003           consume_data_flag = 0 ;
1004           if (dtp->u.p.mode == READING)
1005             {
1006               format_error (dtp, f, "Constant string in input format");
1007               return;
1008             }
1009           write_constant_string (dtp, f);
1010           break;
1011
1012         /* Format codes that don't transfer data.  */
1013         case FMT_X:
1014         case FMT_TR:
1015           consume_data_flag = 0 ;
1016
1017           pos = bytes_used + f->u.n + dtp->u.p.skips;
1018           dtp->u.p.skips = f->u.n + dtp->u.p.skips;
1019           dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
1020
1021           /* Writes occur just before the switch on f->format, above, so
1022              that trailing blanks are suppressed, unless we are doing a
1023              non-advancing write in which case we want to output the blanks
1024              now.  */
1025           if (dtp->u.p.mode == WRITING
1026               && dtp->u.p.advance_status == ADVANCE_NO)
1027             {
1028               write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1029               dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1030             }
1031           if (dtp->u.p.mode == READING)
1032             read_x (dtp, f->u.n);
1033
1034           break;
1035
1036         case FMT_TL:
1037         case FMT_T:
1038           if (f->format == FMT_TL)
1039             {
1040
1041               /* Handle the special case when no bytes have been used yet.
1042                  Cannot go below zero. */
1043               if (bytes_used == 0)
1044                 {
1045                   dtp->u.p.pending_spaces -= f->u.n;
1046                   dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
1047                                             : dtp->u.p.pending_spaces;
1048                   dtp->u.p.skips -= f->u.n;
1049                   dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1050                 }
1051
1052               pos = bytes_used - f->u.n;
1053             }
1054           else /* FMT_T */
1055             {
1056               consume_data_flag = 0;
1057               pos = f->u.n - 1;
1058             }
1059
1060           /* Standard 10.6.1.1: excessive left tabbing is reset to the
1061              left tab limit.  We do not check if the position has gone
1062              beyond the end of record because a subsequent tab could
1063              bring us back again.  */
1064           pos = pos < 0 ? 0 : pos;
1065
1066           dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1067           dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1068                                     + pos - dtp->u.p.max_pos;
1069
1070           if (dtp->u.p.skips == 0)
1071             break;
1072
1073           /* Writes occur just before the switch on f->format, above, so that
1074              trailing blanks are suppressed.  */
1075           if (dtp->u.p.mode == READING)
1076             {
1077               /* Adjust everything for end-of-record condition */
1078               if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1079                 {
1080                   if (dtp->u.p.sf_seen_eor == 2)
1081                     {
1082                       /* The EOR was a CRLF (two bytes wide).  */
1083                       dtp->u.p.current_unit->bytes_left -= 2;
1084                       dtp->u.p.skips -= 2;
1085                     }
1086                   else
1087                     {
1088                       /* The EOR marker was only one byte wide.  */
1089                       dtp->u.p.current_unit->bytes_left--;
1090                       dtp->u.p.skips--;
1091                     }
1092                   bytes_used = pos;
1093                   dtp->u.p.sf_seen_eor = 0;
1094                 }
1095               if (dtp->u.p.skips < 0)
1096                 {
1097                   move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1098                   dtp->u.p.current_unit->bytes_left
1099                     -= (gfc_offset) dtp->u.p.skips;
1100                   dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1101                 }
1102               else
1103                 read_x (dtp, dtp->u.p.skips);
1104             }
1105
1106           break;
1107
1108         case FMT_S:
1109           consume_data_flag = 0 ;
1110           dtp->u.p.sign_status = SIGN_S;
1111           break;
1112
1113         case FMT_SS:
1114           consume_data_flag = 0 ;
1115           dtp->u.p.sign_status = SIGN_SS;
1116           break;
1117
1118         case FMT_SP:
1119           consume_data_flag = 0 ;
1120           dtp->u.p.sign_status = SIGN_SP;
1121           break;
1122
1123         case FMT_BN:
1124           consume_data_flag = 0 ;
1125           dtp->u.p.blank_status = BLANK_NULL;
1126           break;
1127
1128         case FMT_BZ:
1129           consume_data_flag = 0 ;
1130           dtp->u.p.blank_status = BLANK_ZERO;
1131           break;
1132
1133         case FMT_P:
1134           consume_data_flag = 0 ;
1135           dtp->u.p.scale_factor = f->u.k;
1136           break;
1137
1138         case FMT_DOLLAR:
1139           consume_data_flag = 0 ;
1140           dtp->u.p.seen_dollar = 1;
1141           break;
1142
1143         case FMT_SLASH:
1144           consume_data_flag = 0 ;
1145           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1146           next_record (dtp, 0);
1147           break;
1148
1149         case FMT_COLON:
1150           /* A colon descriptor causes us to exit this loop (in
1151              particular preventing another / descriptor from being
1152              processed) unless there is another data item to be
1153              transferred.  */
1154           consume_data_flag = 0 ;
1155           if (n == 0)
1156             return;
1157           break;
1158
1159         default:
1160           internal_error (&dtp->common, "Bad format node");
1161         }
1162
1163       /* Free a buffer that we had to allocate during a sequential
1164          formatted read of a block that was larger than the static
1165          buffer.  */
1166
1167       if (dtp->u.p.line_buffer != scratch)
1168         {
1169           free_mem (dtp->u.p.line_buffer);
1170           dtp->u.p.line_buffer = scratch;
1171         }
1172
1173       /* Adjust the item count and data pointer.  */
1174
1175       if ((consume_data_flag > 0) && (n > 0))
1176       {
1177         n--;
1178         p = ((char *) p) + size;
1179       }
1180
1181       if (dtp->u.p.mode == READING)
1182         dtp->u.p.skips = 0;
1183
1184       pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1185       dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1186
1187     }
1188
1189   return;
1190
1191   /* Come here when we need a data descriptor but don't have one.  We
1192      push the current format node back onto the input, then return and
1193      let the user program call us back with the data.  */
1194  need_data:
1195   unget_format (dtp, f);
1196 }
1197
1198 static void
1199 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1200                     size_t size, size_t nelems)
1201 {
1202   size_t elem;
1203   char *tmp;
1204
1205   tmp = (char *) p;
1206
1207   /* Big loop over all the elements.  */
1208   for (elem = 0; elem < nelems; elem++)
1209     {
1210       dtp->u.p.item_count++;
1211       formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1212     }
1213 }
1214
1215
1216
1217 /* Data transfer entry points.  The type of the data entity is
1218    implicit in the subroutine call.  This prevents us from having to
1219    share a common enum with the compiler.  */
1220
1221 void
1222 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1223 {
1224   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1225     return;
1226   dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1227 }
1228
1229
1230 void
1231 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1232 {
1233   size_t size;
1234   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1235     return;
1236   size = size_from_real_kind (kind);
1237   dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1238 }
1239
1240
1241 void
1242 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1243 {
1244   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1245     return;
1246   dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1247 }
1248
1249
1250 void
1251 transfer_character (st_parameter_dt *dtp, void *p, int len)
1252 {
1253   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1254     return;
1255   /* Currently we support only 1 byte chars, and the library is a bit
1256      confused of character kind vs. length, so we kludge it by setting
1257      kind = length.  */
1258   dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1259 }
1260
1261
1262 void
1263 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1264 {
1265   size_t size;
1266   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1267     return;
1268   size = size_from_complex_kind (kind);
1269   dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1270 }
1271
1272
1273 void
1274 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1275                 gfc_charlen_type charlen)
1276 {
1277   index_type count[GFC_MAX_DIMENSIONS];
1278   index_type extent[GFC_MAX_DIMENSIONS];
1279   index_type stride[GFC_MAX_DIMENSIONS];
1280   index_type stride0, rank, size, type, n;
1281   size_t tsize;
1282   char *data;
1283   bt iotype;
1284
1285   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1286     return;
1287
1288   type = GFC_DESCRIPTOR_TYPE (desc);
1289   size = GFC_DESCRIPTOR_SIZE (desc);
1290
1291   /* FIXME: What a kludge: Array descriptors and the IO library use
1292      different enums for types.  */
1293   switch (type)
1294     {
1295     case GFC_DTYPE_UNKNOWN:
1296       iotype = BT_NULL;  /* Is this correct?  */
1297       break;
1298     case GFC_DTYPE_INTEGER:
1299       iotype = BT_INTEGER;
1300       break;
1301     case GFC_DTYPE_LOGICAL:
1302       iotype = BT_LOGICAL;
1303       break;
1304     case GFC_DTYPE_REAL:
1305       iotype = BT_REAL;
1306       break;
1307     case GFC_DTYPE_COMPLEX:
1308       iotype = BT_COMPLEX;
1309       break;
1310     case GFC_DTYPE_CHARACTER:
1311       iotype = BT_CHARACTER;
1312       /* FIXME: Currently dtype contains the charlen, which is
1313          clobbered if charlen > 2**24. That's why we use a separate
1314          argument for the charlen. However, if we want to support
1315          non-8-bit charsets we need to fix dtype to contain
1316          sizeof(chartype) and fix the code below.  */
1317       size = charlen;
1318       kind = charlen;
1319       break;
1320     case GFC_DTYPE_DERIVED:
1321       internal_error (&dtp->common,
1322                 "Derived type I/O should have been handled via the frontend.");
1323       break;
1324     default:
1325       internal_error (&dtp->common, "transfer_array(): Bad type");
1326     }
1327
1328   rank = GFC_DESCRIPTOR_RANK (desc);
1329   for (n = 0; n < rank; n++)
1330     {
1331       count[n] = 0;
1332       stride[n] = desc->dim[n].stride;
1333       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1334
1335       /* If the extent of even one dimension is zero, then the entire
1336          array section contains zero elements, so we return.  */
1337       if (extent[n] == 0)
1338         return;
1339     }
1340
1341   stride0 = stride[0];
1342
1343   /* If the innermost dimension has stride 1, we can do the transfer
1344      in contiguous chunks.  */
1345   if (stride0 == 1)
1346     tsize = extent[0];
1347   else
1348     tsize = 1;
1349
1350   data = GFC_DESCRIPTOR_DATA (desc);
1351
1352   while (data)
1353     {
1354       dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1355       data += stride0 * size * tsize;
1356       count[0] += tsize;
1357       n = 0;
1358       while (count[n] == extent[n])
1359         {
1360           count[n] = 0;
1361           data -= stride[n] * extent[n] * size;
1362           n++;
1363           if (n == rank)
1364             {
1365               data = NULL;
1366               break;
1367             }
1368           else
1369             {
1370               count[n]++;
1371               data += stride[n] * size;
1372             }
1373         }
1374     }
1375 }
1376
1377
1378 /* Preposition a sequential unformatted file while reading.  */
1379
1380 static void
1381 us_read (st_parameter_dt *dtp)
1382 {
1383   char *p;
1384   int n;
1385   int nr;
1386   GFC_INTEGER_4 i4;
1387   GFC_INTEGER_8 i8;
1388   gfc_offset i;
1389
1390   if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1391     return;
1392
1393   if (compile_options.record_marker == 0)
1394     n = sizeof (gfc_offset);
1395   else
1396     n = compile_options.record_marker;
1397
1398   nr = n;
1399
1400   p = salloc_r (dtp->u.p.current_unit->s, &n);
1401
1402   if (n == 0)
1403     {
1404       dtp->u.p.current_unit->endfile = AT_ENDFILE;
1405       return;  /* end of file */
1406     }
1407
1408   if (p == NULL || n != nr)
1409     {
1410       generate_error (&dtp->common, ERROR_BAD_US, NULL);
1411       return;
1412     }
1413
1414   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
1415   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1416     {
1417       switch (compile_options.record_marker)
1418         {
1419         case 0:
1420           memcpy (&i, p, sizeof(gfc_offset));
1421           break;
1422
1423         case sizeof(GFC_INTEGER_4):
1424           memcpy (&i4, p, sizeof (i4));
1425           i = i4;
1426           break;
1427
1428         case sizeof(GFC_INTEGER_8):
1429           memcpy (&i8, p, sizeof (i8));
1430           i = i8;
1431           break;
1432
1433         default:
1434           runtime_error ("Illegal value for record marker");
1435           break;
1436         }
1437     }
1438   else
1439       switch (compile_options.record_marker)
1440         {
1441         case 0:
1442           reverse_memcpy (&i, p, sizeof(gfc_offset));
1443           break;
1444
1445         case sizeof(GFC_INTEGER_4):
1446           reverse_memcpy (&i4, p, sizeof (i4));
1447           i = i4;
1448           break;
1449
1450         case sizeof(GFC_INTEGER_8):
1451           reverse_memcpy (&i8, p, sizeof (i8));
1452           i = i8;
1453           break;
1454
1455         default:
1456           runtime_error ("Illegal value for record marker");
1457           break;
1458         }
1459
1460   dtp->u.p.current_unit->bytes_left = i;
1461 }
1462
1463
1464 /* Preposition a sequential unformatted file while writing.  This
1465    amount to writing a bogus length that will be filled in later.  */
1466
1467 static void
1468 us_write (st_parameter_dt *dtp)
1469 {
1470   size_t nbytes;
1471   gfc_offset dummy;
1472
1473   dummy = 0;
1474
1475   if (compile_options.record_marker == 0)
1476     nbytes = sizeof (gfc_offset);
1477   else
1478     nbytes = compile_options.record_marker ;
1479
1480   if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1481     generate_error (&dtp->common, ERROR_OS, NULL);
1482
1483   /* For sequential unformatted, we write until we have more bytes
1484      than can fit in the record markers. If disk space runs out first,
1485      it will error on the write.  */
1486   dtp->u.p.current_unit->recl = max_offset;
1487
1488   dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1489 }
1490
1491
1492 /* Position to the next record prior to transfer.  We are assumed to
1493    be before the next record.  We also calculate the bytes in the next
1494    record.  */
1495
1496 static void
1497 pre_position (st_parameter_dt *dtp)
1498 {
1499   if (dtp->u.p.current_unit->current_record)
1500     return;                     /* Already positioned.  */
1501
1502   switch (current_mode (dtp))
1503     {
1504     case FORMATTED_STREAM:
1505     case UNFORMATTED_STREAM:
1506       /* There are no records with stream I/O.  Set the default position
1507          to the beginning of the file if no position was specified.  */
1508       if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1509         dtp->rec = 1;
1510       break;
1511     
1512     case UNFORMATTED_SEQUENTIAL:
1513       if (dtp->u.p.mode == READING)
1514         us_read (dtp);
1515       else
1516         us_write (dtp);
1517
1518       break;
1519
1520     case FORMATTED_SEQUENTIAL:
1521     case FORMATTED_DIRECT:
1522     case UNFORMATTED_DIRECT:
1523       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1524       break;
1525     }
1526
1527   dtp->u.p.current_unit->current_record = 1;
1528 }
1529
1530
1531 /* Initialize things for a data transfer.  This code is common for
1532    both reading and writing.  */
1533
1534 static void
1535 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1536 {
1537   unit_flags u_flags;  /* Used for creating a unit if needed.  */
1538   GFC_INTEGER_4 cf = dtp->common.flags;
1539   namelist_info *ionml;
1540
1541   ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1542   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1543   dtp->u.p.ionml = ionml;
1544   dtp->u.p.mode = read_flag ? READING : WRITING;
1545
1546   if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1547     dtp->u.p.size_used = 0;  /* Initialize the count.  */
1548
1549   dtp->u.p.current_unit = get_unit (dtp, 1);
1550   if (dtp->u.p.current_unit->s == NULL)
1551   {  /* Open the unit with some default flags.  */
1552      st_parameter_open opp;
1553      unit_convert conv;
1554
1555      if (dtp->common.unit < 0)
1556      {
1557        close_unit (dtp->u.p.current_unit);
1558        dtp->u.p.current_unit = NULL;
1559        generate_error (&dtp->common, ERROR_BAD_OPTION,
1560                        "Bad unit number in OPEN statement");
1561        return;
1562      }
1563      memset (&u_flags, '\0', sizeof (u_flags));
1564      u_flags.access = ACCESS_SEQUENTIAL;
1565      u_flags.action = ACTION_READWRITE;
1566
1567      /* Is it unformatted?  */
1568      if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1569                  | IOPARM_DT_IONML_SET)))
1570        u_flags.form = FORM_UNFORMATTED;
1571      else
1572        u_flags.form = FORM_UNSPECIFIED;
1573
1574      u_flags.delim = DELIM_UNSPECIFIED;
1575      u_flags.blank = BLANK_UNSPECIFIED;
1576      u_flags.pad = PAD_UNSPECIFIED;
1577      u_flags.status = STATUS_UNKNOWN;
1578
1579      conv = get_unformatted_convert (dtp->common.unit);
1580
1581      if (conv == CONVERT_NONE)
1582        conv = compile_options.convert;
1583
1584      /* We use l8_to_l4_offset, which is 0 on little-endian machines
1585         and 1 on big-endian machines.  */
1586      switch (conv)
1587        {
1588        case CONVERT_NATIVE:
1589        case CONVERT_SWAP:
1590          break;
1591          
1592        case CONVERT_BIG:
1593          conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1594          break;
1595       
1596        case CONVERT_LITTLE:
1597          conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1598          break;
1599          
1600        default:
1601          internal_error (&opp.common, "Illegal value for CONVERT");
1602          break;
1603        }
1604
1605      u_flags.convert = conv;
1606
1607      opp.common = dtp->common;
1608      opp.common.flags &= IOPARM_COMMON_MASK;
1609      dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1610      dtp->common.flags &= ~IOPARM_COMMON_MASK;
1611      dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1612      if (dtp->u.p.current_unit == NULL)
1613        return;
1614   }
1615
1616   /* Check the action.  */
1617
1618   if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1619     generate_error (&dtp->common, ERROR_BAD_ACTION,
1620                     "Cannot read from file opened for WRITE");
1621
1622   if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1623     generate_error (&dtp->common, ERROR_BAD_ACTION,
1624                     "Cannot write to file opened for READ");
1625
1626   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1627     return;
1628
1629   dtp->u.p.first_item = 1;
1630
1631   /* Check the format.  */
1632
1633   if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1634     parse_format (dtp);
1635
1636   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1637     return;
1638
1639   if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1640       && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1641          != 0)
1642     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1643                     "Format present for UNFORMATTED data transfer");
1644
1645   if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1646      {
1647         if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1648            generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1649                     "A format cannot be specified with a namelist");
1650      }
1651   else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1652            !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1653     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1654                     "Missing format for FORMATTED data transfer");
1655
1656   if (is_internal_unit (dtp)
1657       && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1658     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1659                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1660
1661   /* Check the record or position number.  */
1662
1663   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1664       && (cf & IOPARM_DT_HAS_REC) == 0)
1665     {
1666       generate_error (&dtp->common, ERROR_MISSING_OPTION,
1667                       "Direct access data transfer requires record number");
1668       return;
1669     }
1670
1671   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1672       && (cf & IOPARM_DT_HAS_REC) != 0)
1673     {
1674       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1675                       "Record number not allowed for sequential access data transfer");
1676       return;
1677     }
1678
1679   /* Process the ADVANCE option.  */
1680
1681   dtp->u.p.advance_status
1682     = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1683       find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1684                    "Bad ADVANCE parameter in data transfer statement");
1685
1686   if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1687     {
1688       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1689         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1690                         "ADVANCE specification conflicts with sequential access");
1691
1692       if (is_internal_unit (dtp))
1693         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1694                         "ADVANCE specification conflicts with internal file");
1695
1696       if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1697           != IOPARM_DT_HAS_FORMAT)
1698         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1699                         "ADVANCE specification requires an explicit format");
1700     }
1701
1702   if (read_flag)
1703     {
1704       if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1705         generate_error (&dtp->common, ERROR_MISSING_OPTION,
1706                         "EOR specification requires an ADVANCE specification of NO");
1707
1708       if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1709         generate_error (&dtp->common, ERROR_MISSING_OPTION,
1710                         "SIZE specification requires an ADVANCE specification of NO");
1711
1712     }
1713   else
1714     {                           /* Write constraints.  */
1715       if ((cf & IOPARM_END) != 0)
1716         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1717                         "END specification cannot appear in a write statement");
1718
1719       if ((cf & IOPARM_EOR) != 0)
1720         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1721                         "EOR specification cannot appear in a write statement");
1722
1723       if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1724         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1725                         "SIZE specification cannot appear in a write statement");
1726     }
1727
1728   if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1729     dtp->u.p.advance_status = ADVANCE_YES;
1730   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1731     return;
1732
1733   /* Sanity checks on the record number.  */
1734   if ((cf & IOPARM_DT_HAS_REC) != 0)
1735     {
1736       if (dtp->rec <= 0)
1737         {
1738           generate_error (&dtp->common, ERROR_BAD_OPTION,
1739                           "Record number must be positive");
1740           return;
1741         }
1742
1743       if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1744         {
1745           generate_error (&dtp->common, ERROR_BAD_OPTION,
1746                           "Record number too large");
1747           return;
1748         }
1749
1750       /* Check to see if we might be reading what we wrote before  */
1751
1752       if (dtp->u.p.mode == READING
1753           && dtp->u.p.current_unit->mode == WRITING
1754           && !is_internal_unit (dtp))
1755          flush(dtp->u.p.current_unit->s);
1756
1757       /* Check whether the record exists to be read.  Only
1758          a partial record needs to exist.  */
1759
1760       if (dtp->u.p.mode == READING && (dtp->rec -1)
1761           * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1762         {
1763           generate_error (&dtp->common, ERROR_BAD_OPTION,
1764                           "Non-existing record number");
1765           return;
1766         }
1767
1768       /* Position the file.  */
1769       if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1770                   * dtp->u.p.current_unit->recl) == FAILURE)
1771         {
1772           generate_error (&dtp->common, ERROR_OS, NULL);
1773           return;
1774         }
1775     }
1776
1777   /* Overwriting an existing sequential file ?
1778      it is always safe to truncate the file on the first write */
1779   if (dtp->u.p.mode == WRITING
1780       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1781       && dtp->u.p.current_unit->last_record == 0 
1782       && !is_preconnected(dtp->u.p.current_unit->s))
1783         struncate(dtp->u.p.current_unit->s);
1784
1785   /* Bugware for badly written mixed C-Fortran I/O.  */
1786   flush_if_preconnected(dtp->u.p.current_unit->s);
1787
1788   dtp->u.p.current_unit->mode = dtp->u.p.mode;
1789
1790   /* Set the initial value of flags.  */
1791
1792   dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1793   dtp->u.p.sign_status = SIGN_S;
1794
1795   pre_position (dtp);
1796
1797   /* Set up the subroutine that will handle the transfers.  */
1798
1799   if (read_flag)
1800     {
1801       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1802         dtp->u.p.transfer = unformatted_read;
1803       else
1804         {
1805           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1806             dtp->u.p.transfer = list_formatted_read;
1807           else
1808             dtp->u.p.transfer = formatted_transfer;
1809         }
1810     }
1811   else
1812     {
1813       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1814         dtp->u.p.transfer = unformatted_write;
1815       else
1816         {
1817           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1818             dtp->u.p.transfer = list_formatted_write;
1819           else
1820             dtp->u.p.transfer = formatted_transfer;
1821         }
1822     }
1823
1824   /* Make sure that we don't do a read after a nonadvancing write.  */
1825
1826   if (read_flag)
1827     {
1828       if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1829         {
1830           generate_error (&dtp->common, ERROR_BAD_OPTION,
1831                           "Cannot READ after a nonadvancing WRITE");
1832           return;
1833         }
1834     }
1835   else
1836     {
1837       if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1838         dtp->u.p.current_unit->read_bad = 1;
1839     }
1840
1841   /* Start the data transfer if we are doing a formatted transfer.  */
1842   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1843       && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1844       && dtp->u.p.ionml == NULL)
1845     formatted_transfer (dtp, 0, NULL, 0, 0, 1);
1846 }
1847
1848 /* Initialize an array_loop_spec given the array descriptor.  The function
1849    returns the index of the last element of the array.  */
1850    
1851 gfc_offset
1852 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1853 {
1854   int rank = GFC_DESCRIPTOR_RANK(desc);
1855   int i;
1856   gfc_offset index; 
1857
1858   index = 1;
1859   for (i=0; i<rank; i++)
1860     {
1861       ls[i].idx = 1;
1862       ls[i].start = desc->dim[i].lbound;
1863       ls[i].end = desc->dim[i].ubound;
1864       ls[i].step = desc->dim[i].stride;
1865       
1866       index += (desc->dim[i].ubound - desc->dim[i].lbound)
1867                       * desc->dim[i].stride;
1868     }
1869   return index;
1870 }
1871
1872 /* Determine the index to the next record in an internal unit array by
1873    by incrementing through the array_loop_spec.  TODO:  Implement handling
1874    negative strides. */
1875    
1876 gfc_offset
1877 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
1878 {
1879   int i, carry;
1880   gfc_offset index;
1881   
1882   carry = 1;
1883   index = 0;
1884   
1885   for (i = 0; i < dtp->u.p.current_unit->rank; i++)
1886     {
1887       if (carry)
1888         {
1889           ls[i].idx++;
1890           if (ls[i].idx > ls[i].end)
1891             {
1892               ls[i].idx = ls[i].start;
1893               carry = 1;
1894             }
1895           else
1896             carry = 0;
1897         }
1898       index = index + (ls[i].idx - 1) * ls[i].step;
1899     }
1900   return index;
1901 }
1902
1903 /* Space to the next record for read mode.  If the file is not
1904    seekable, we read MAX_READ chunks until we get to the right
1905    position.  */
1906
1907 #define MAX_READ 4096
1908
1909 static void
1910 next_record_r (st_parameter_dt *dtp)
1911 {
1912   gfc_offset new, record;
1913   int bytes_left, rlength, length;
1914   char *p;
1915
1916   switch (current_mode (dtp))
1917     {
1918     /* No records in STREAM I/O.  */
1919     case FORMATTED_STREAM:
1920     case UNFORMATTED_STREAM:
1921       return;
1922     
1923     case UNFORMATTED_SEQUENTIAL:
1924
1925       /* Skip over tail */
1926       dtp->u.p.current_unit->bytes_left +=
1927         compile_options.record_marker == 0 ?
1928         sizeof (gfc_offset) : compile_options.record_marker;
1929       
1930       /* Fall through...  */
1931
1932     case FORMATTED_DIRECT:
1933     case UNFORMATTED_DIRECT:
1934       if (dtp->u.p.current_unit->bytes_left == 0)
1935         break;
1936
1937       if (is_seekable (dtp->u.p.current_unit->s))
1938         {
1939           new = file_position (dtp->u.p.current_unit->s)
1940                 + dtp->u.p.current_unit->bytes_left;
1941
1942           /* Direct access files do not generate END conditions,
1943              only I/O errors.  */
1944           if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
1945             generate_error (&dtp->common, ERROR_OS, NULL);
1946
1947         }
1948       else
1949         {                       /* Seek by reading data.  */
1950           while (dtp->u.p.current_unit->bytes_left > 0)
1951             {
1952               rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
1953                 MAX_READ : dtp->u.p.current_unit->bytes_left;
1954
1955               p = salloc_r (dtp->u.p.current_unit->s, &rlength);
1956               if (p == NULL)
1957                 {
1958                   generate_error (&dtp->common, ERROR_OS, NULL);
1959                   break;
1960                 }
1961
1962               dtp->u.p.current_unit->bytes_left -= length;
1963             }
1964         }
1965       break;
1966
1967     case FORMATTED_SEQUENTIAL:
1968       length = 1;
1969       /* sf_read has already terminated input because of an '\n'  */
1970       if (dtp->u.p.sf_seen_eor)
1971         {
1972           dtp->u.p.sf_seen_eor = 0;
1973           break;
1974         }
1975
1976       if (is_internal_unit (dtp))
1977         {
1978           if (is_array_io (dtp))
1979             {
1980               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1981
1982               /* Now seek to this record.  */
1983               record = record * dtp->u.p.current_unit->recl;
1984               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1985                 {
1986                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
1987                   break;
1988                 }
1989               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1990             }
1991           else  
1992             {
1993               bytes_left = (int) dtp->u.p.current_unit->bytes_left;
1994               p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
1995               if (p != NULL)
1996                 dtp->u.p.current_unit->bytes_left
1997                   = dtp->u.p.current_unit->recl;
1998             } 
1999           break;
2000         }
2001       else do
2002         {
2003           p = salloc_r (dtp->u.p.current_unit->s, &length);
2004
2005           if (p == NULL)
2006             {
2007               generate_error (&dtp->common, ERROR_OS, NULL);
2008               break;
2009             }
2010
2011           if (length == 0)
2012             {
2013               dtp->u.p.current_unit->endfile = AT_ENDFILE;
2014               break;
2015             }
2016         }
2017       while (*p != '\n');
2018
2019       break;
2020     }
2021
2022   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2023     test_endfile (dtp->u.p.current_unit);
2024 }
2025
2026
2027 /* Small utility function to write a record marker, taking care of
2028    byte swapping and of choosing the correct size.  */
2029
2030 inline static int
2031 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2032 {
2033   size_t len;
2034   GFC_INTEGER_4 buf4;
2035   GFC_INTEGER_8 buf8;
2036   char p[sizeof (GFC_INTEGER_8)];
2037
2038   if (compile_options.record_marker == 0)
2039     len = sizeof (gfc_offset);
2040   else
2041     len = compile_options.record_marker;
2042
2043   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
2044   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2045     {
2046       switch (compile_options.record_marker)
2047         {
2048         case 0:
2049           return swrite (dtp->u.p.current_unit->s, &buf, &len);
2050           break;
2051
2052         case sizeof (GFC_INTEGER_4):
2053           buf4 = buf;
2054           return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2055           break;
2056
2057         case sizeof (GFC_INTEGER_8):
2058           buf8 = buf;
2059           return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2060           break;
2061
2062         default:
2063           runtime_error ("Illegal value for record marker");
2064           break;
2065         }
2066     }
2067   else
2068     {
2069       switch (compile_options.record_marker)
2070         {
2071         case 0:
2072           reverse_memcpy (p, &buf, sizeof (gfc_offset));
2073           return swrite (dtp->u.p.current_unit->s, p, &len);
2074           break;
2075
2076         case sizeof (GFC_INTEGER_4):
2077           buf4 = buf;
2078           reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2079           return swrite (dtp->u.p.current_unit->s, p, &len);
2080           break;
2081
2082         case sizeof (GFC_INTEGER_8):
2083           buf8 = buf;
2084           reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
2085           return swrite (dtp->u.p.current_unit->s, p, &len);
2086           break;
2087
2088         default:
2089           runtime_error ("Illegal value for record marker");
2090           break;
2091         }
2092     }
2093
2094 }
2095
2096
2097 /* Position to the next record in write mode.  */
2098
2099 static void
2100 next_record_w (st_parameter_dt *dtp, int done)
2101 {
2102   gfc_offset c, m, record, max_pos;
2103   int length;
2104   char *p;
2105   size_t record_marker;
2106
2107   /* Zero counters for X- and T-editing.  */
2108   max_pos = dtp->u.p.max_pos;
2109   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2110
2111   switch (current_mode (dtp))
2112     {
2113     /* No records in STREAM I/O.  */
2114     case FORMATTED_STREAM:
2115     case UNFORMATTED_STREAM:
2116       return;
2117
2118     case FORMATTED_DIRECT:
2119       if (dtp->u.p.current_unit->bytes_left == 0)
2120         break;
2121
2122       if (sset (dtp->u.p.current_unit->s, ' ', 
2123                 dtp->u.p.current_unit->bytes_left) == FAILURE)
2124         goto io_error;
2125
2126       break;
2127
2128     case UNFORMATTED_DIRECT:
2129       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2130         goto io_error;
2131       break;
2132
2133     case UNFORMATTED_SEQUENTIAL:
2134       /* Bytes written.  */
2135       m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
2136       c = file_position (dtp->u.p.current_unit->s);
2137
2138       /* Write the length tail.  */
2139
2140       if (write_us_marker (dtp, m) != 0)
2141         goto io_error;
2142
2143       if (compile_options.record_marker == 4)
2144         record_marker = sizeof(GFC_INTEGER_4);
2145       else
2146         record_marker = sizeof (gfc_offset);
2147
2148       /* Seek to the head and overwrite the bogus length with the real
2149          length.  */
2150
2151       if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2152           == FAILURE)
2153         goto io_error;
2154
2155       if (write_us_marker (dtp, m) != 0)
2156         goto io_error;
2157
2158       /* Seek past the end of the current record.  */
2159
2160       if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2161         goto io_error;
2162
2163       break;
2164
2165     case FORMATTED_SEQUENTIAL:
2166
2167       if (is_internal_unit (dtp))
2168         {
2169           if (is_array_io (dtp))
2170             {
2171               length = (int) dtp->u.p.current_unit->bytes_left;
2172               
2173               /* If the farthest position reached is greater than current
2174               position, adjust the position and set length to pad out
2175               whats left.  Otherwise just pad whats left.
2176               (for character array unit) */
2177               m = dtp->u.p.current_unit->recl
2178                         - dtp->u.p.current_unit->bytes_left;
2179               if (max_pos > m)
2180                 {
2181                   length = (int) (max_pos - m);
2182                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2183                   length = (int) (dtp->u.p.current_unit->recl - max_pos);
2184                 }
2185
2186               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2187                 {
2188                   generate_error (&dtp->common, ERROR_END, NULL);
2189                   return;
2190                 }
2191
2192               /* Now that the current record has been padded out,
2193                  determine where the next record in the array is. */
2194               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2195               if (record == 0)
2196                 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2197               
2198               /* Now seek to this record */
2199               record = record * dtp->u.p.current_unit->recl;
2200
2201               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2202                 {
2203                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2204                   return;
2205                 }
2206
2207               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2208             }
2209           else
2210             {
2211               length = 1;
2212
2213               /* If this is the last call to next_record move to the farthest
2214                  position reached and set length to pad out the remainder
2215                  of the record. (for character scaler unit) */
2216               if (done)
2217                 {
2218                   m = dtp->u.p.current_unit->recl
2219                         - dtp->u.p.current_unit->bytes_left;
2220                   if (max_pos > m)
2221                     {
2222                       length = (int) (max_pos - m);
2223                       p = salloc_w (dtp->u.p.current_unit->s, &length);
2224                       length = (int) (dtp->u.p.current_unit->recl - max_pos);
2225                     }
2226                   else
2227                     length = (int) dtp->u.p.current_unit->bytes_left;
2228                 }
2229               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2230                 {
2231                   generate_error (&dtp->common, ERROR_END, NULL);
2232                   return;
2233                 }
2234             }
2235         }
2236       else
2237         {
2238           if (dtp->u.p.current_unit->bytes_left == 0)
2239             break;
2240
2241           /* If this is the last call to next_record move to the farthest
2242           position reached in preparation for completing the record.
2243           (for file unit) */
2244           if (done)
2245             {
2246               m = dtp->u.p.current_unit->recl -
2247                         dtp->u.p.current_unit->bytes_left;
2248               if (max_pos > m)
2249                 {
2250                   length = (int) (max_pos - m);
2251                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2252                 }
2253             }
2254           size_t len;
2255           const char crlf[] = "\r\n";
2256 #ifdef HAVE_CRLF
2257           len = 2;
2258 #else
2259           len = 1;
2260 #endif
2261           if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2262             goto io_error;
2263         }
2264
2265       break;
2266
2267     io_error:
2268       generate_error (&dtp->common, ERROR_OS, NULL);
2269       break;
2270     }
2271 }
2272
2273 /* Position to the next record, which means moving to the end of the
2274    current record.  This can happen under several different
2275    conditions.  If the done flag is not set, we get ready to process
2276    the next record.  */
2277
2278 void
2279 next_record (st_parameter_dt *dtp, int done)
2280 {
2281   if (is_stream_io (dtp))
2282     return;
2283
2284   gfc_offset fp; /* File position.  */
2285
2286   dtp->u.p.current_unit->read_bad = 0;
2287
2288   if (dtp->u.p.mode == READING)
2289     next_record_r (dtp);
2290   else
2291     next_record_w (dtp, done);
2292
2293   /* keep position up to date for INQUIRE */
2294   dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2295   dtp->u.p.current_unit->current_record = 0;
2296   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2297    {
2298     fp = file_position (dtp->u.p.current_unit->s);
2299     /* Calculate next record, rounding up partial records.  */
2300     dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1)
2301                                 / dtp->u.p.current_unit->recl;
2302    }
2303   else
2304     dtp->u.p.current_unit->last_record++;
2305
2306   if (!done)
2307     pre_position (dtp);
2308 }
2309
2310
2311 /* Finalize the current data transfer.  For a nonadvancing transfer,
2312    this means advancing to the next record.  For internal units close the
2313    stream associated with the unit.  */
2314
2315 static void
2316 finalize_transfer (st_parameter_dt *dtp)
2317 {
2318   jmp_buf eof_jump;
2319   GFC_INTEGER_4 cf = dtp->common.flags;
2320
2321   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2322     *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
2323
2324   if (dtp->u.p.eor_condition)
2325     {
2326       generate_error (&dtp->common, ERROR_EOR, NULL);
2327       return;
2328     }
2329
2330   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2331     return;
2332
2333   if ((dtp->u.p.ionml != NULL)
2334       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2335     {
2336        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2337          namelist_read (dtp);
2338        else
2339          namelist_write (dtp);
2340     }
2341
2342   dtp->u.p.transfer = NULL;
2343   if (dtp->u.p.current_unit == NULL)
2344     return;
2345
2346   dtp->u.p.eof_jump = &eof_jump;
2347   if (setjmp (eof_jump))
2348     {
2349       generate_error (&dtp->common, ERROR_END, NULL);
2350       return;
2351     }
2352
2353   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2354     finish_list_read (dtp);
2355   else if (!is_stream_io (dtp))
2356     {
2357       dtp->u.p.current_unit->current_record = 0;
2358       if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
2359         {
2360           /* Most systems buffer lines, so force the partial record
2361              to be written out.  */
2362           if (!is_internal_unit (dtp))
2363             flush (dtp->u.p.current_unit->s);
2364           dtp->u.p.seen_dollar = 0;
2365           return;
2366         }
2367       next_record (dtp, 1);
2368     }
2369   else
2370     {
2371       flush (dtp->u.p.current_unit->s);
2372       dtp->u.p.current_unit->last_record = dtp->rec;
2373     }
2374
2375   sfree (dtp->u.p.current_unit->s);
2376 }
2377
2378 /* Transfer function for IOLENGTH. It doesn't actually do any
2379    data transfer, it just updates the length counter.  */
2380
2381 static void
2382 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), 
2383                    void *dest __attribute__ ((unused)),
2384                    int kind __attribute__((unused)), 
2385                    size_t size, size_t nelems)
2386 {
2387   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2388     *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2389 }
2390
2391
2392 /* Initialize the IOLENGTH data transfer. This function is in essence
2393    a very much simplified version of data_transfer_init(), because it
2394    doesn't have to deal with units at all.  */
2395
2396 static void
2397 iolength_transfer_init (st_parameter_dt *dtp)
2398 {
2399   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2400     *dtp->iolength = 0;
2401
2402   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2403
2404   /* Set up the subroutine that will handle the transfers.  */
2405
2406   dtp->u.p.transfer = iolength_transfer;
2407 }
2408
2409
2410 /* Library entry point for the IOLENGTH form of the INQUIRE
2411    statement. The IOLENGTH form requires no I/O to be performed, but
2412    it must still be a runtime library call so that we can determine
2413    the iolength for dynamic arrays and such.  */
2414
2415 extern void st_iolength (st_parameter_dt *);
2416 export_proto(st_iolength);
2417
2418 void
2419 st_iolength (st_parameter_dt *dtp)
2420 {
2421   library_start (&dtp->common);
2422   iolength_transfer_init (dtp);
2423 }
2424
2425 extern void st_iolength_done (st_parameter_dt *);
2426 export_proto(st_iolength_done);
2427
2428 void
2429 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2430 {
2431   free_ionml (dtp);
2432   if (dtp->u.p.scratch != NULL)
2433     free_mem (dtp->u.p.scratch);
2434   library_end ();
2435 }
2436
2437
2438 /* The READ statement.  */
2439
2440 extern void st_read (st_parameter_dt *);
2441 export_proto(st_read);
2442
2443 void
2444 st_read (st_parameter_dt *dtp)
2445 {
2446   library_start (&dtp->common);
2447
2448   data_transfer_init (dtp, 1);
2449
2450   /* Handle complications dealing with the endfile record.  It is
2451      significant that this is the only place where ERROR_END is
2452      generated.  Reading an end of file elsewhere is either end of
2453      record or an I/O error. */
2454
2455   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2456     switch (dtp->u.p.current_unit->endfile)
2457       {
2458       case NO_ENDFILE:
2459         break;
2460
2461       case AT_ENDFILE:
2462         if (!is_internal_unit (dtp))
2463           {
2464             generate_error (&dtp->common, ERROR_END, NULL);
2465             dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2466             dtp->u.p.current_unit->current_record = 0;
2467           }
2468         break;
2469
2470       case AFTER_ENDFILE:
2471         generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2472         dtp->u.p.current_unit->current_record = 0;
2473         break;
2474       }
2475 }
2476
2477 extern void st_read_done (st_parameter_dt *);
2478 export_proto(st_read_done);
2479
2480 void
2481 st_read_done (st_parameter_dt *dtp)
2482 {
2483   finalize_transfer (dtp);
2484   free_format_data (dtp);
2485   free_ionml (dtp);
2486   if (dtp->u.p.scratch != NULL)
2487     free_mem (dtp->u.p.scratch);
2488   if (dtp->u.p.current_unit != NULL)
2489     unlock_unit (dtp->u.p.current_unit);
2490
2491   free_internal_unit (dtp);
2492   
2493   library_end ();
2494 }
2495
2496 extern void st_write (st_parameter_dt *);
2497 export_proto(st_write);
2498
2499 void
2500 st_write (st_parameter_dt *dtp)
2501 {
2502   library_start (&dtp->common);
2503   data_transfer_init (dtp, 0);
2504 }
2505
2506 extern void st_write_done (st_parameter_dt *);
2507 export_proto(st_write_done);
2508
2509 void
2510 st_write_done (st_parameter_dt *dtp)
2511 {
2512   finalize_transfer (dtp);
2513
2514   /* Deal with endfile conditions associated with sequential files.  */
2515
2516   if (dtp->u.p.current_unit != NULL 
2517       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2518     switch (dtp->u.p.current_unit->endfile)
2519       {
2520       case AT_ENDFILE:          /* Remain at the endfile record.  */
2521         break;
2522
2523       case AFTER_ENDFILE:
2524         dtp->u.p.current_unit->endfile = AT_ENDFILE;    /* Just at it now.  */
2525         break;
2526
2527       case NO_ENDFILE:
2528         /* Get rid of whatever is after this record.  */
2529         if (!is_internal_unit (dtp))
2530           {
2531             flush (dtp->u.p.current_unit->s);
2532             if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2533               generate_error (&dtp->common, ERROR_OS, NULL);
2534           }
2535         dtp->u.p.current_unit->endfile = AT_ENDFILE;
2536         break;
2537       }
2538
2539   free_format_data (dtp);
2540   free_ionml (dtp);
2541   if (dtp->u.p.scratch != NULL)
2542     free_mem (dtp->u.p.scratch);
2543   if (dtp->u.p.current_unit != NULL)
2544     unlock_unit (dtp->u.p.current_unit);
2545   
2546   free_internal_unit (dtp);
2547
2548   library_end ();
2549 }
2550
2551 /* Receives the scalar information for namelist objects and stores it
2552    in a linked list of namelist_info types.  */
2553
2554 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2555                             GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2556 export_proto(st_set_nml_var);
2557
2558
2559 void
2560 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2561                 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2562                 GFC_INTEGER_4 dtype)
2563 {
2564   namelist_info *t1 = NULL;
2565   namelist_info *nml;
2566
2567   nml = (namelist_info*) get_mem (sizeof (namelist_info));
2568
2569   nml->mem_pos = var_addr;
2570
2571   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2572   strcpy (nml->var_name, var_name);
2573
2574   nml->len = (int) len;
2575   nml->string_length = (index_type) string_length;
2576
2577   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2578   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2579   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2580
2581   if (nml->var_rank > 0)
2582     {
2583       nml->dim = (descriptor_dimension*)
2584                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
2585       nml->ls = (array_loop_spec*)
2586                   get_mem (nml->var_rank * sizeof (array_loop_spec));
2587     }
2588   else
2589     {
2590       nml->dim = NULL;
2591       nml->ls = NULL;
2592     }
2593
2594   nml->next = NULL;
2595
2596   if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2597     {
2598       dtp->common.flags |= IOPARM_DT_IONML_SET;
2599       dtp->u.p.ionml = nml;
2600     }
2601   else
2602     {
2603       for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2604       t1->next = nml;
2605     }
2606 }
2607
2608 /* Store the dimensional information for the namelist object.  */
2609 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2610                                 GFC_INTEGER_4, GFC_INTEGER_4,
2611                                 GFC_INTEGER_4);
2612 export_proto(st_set_nml_var_dim);
2613
2614 void
2615 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2616                     GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2617                     GFC_INTEGER_4 ubound)
2618 {
2619   namelist_info * nml;
2620   int n;
2621
2622   n = (int)n_dim;
2623
2624   for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2625
2626   nml->dim[n].stride = (ssize_t)stride;
2627   nml->dim[n].lbound = (ssize_t)lbound;
2628   nml->dim[n].ubound = (ssize_t)ubound;
2629 }
2630
2631 /* Reverse memcpy - used for byte swapping.  */
2632
2633 void reverse_memcpy (void *dest, const void *src, size_t n)
2634 {
2635   char *d, *s;
2636   size_t i;
2637
2638   d = (char *) dest;
2639   s = (char *) src + n - 1;
2640
2641   /* Write with ascending order - this is likely faster
2642      on modern architectures because of write combining.  */
2643   for (i=0; i<n; i++)
2644       *(d++) = *(s--);
2645 }