OSDN Git Service

2006-09-14 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                  dtp->u.p.current_unit->strm_pos - 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->u.p.current_unit->strm_pos += (gfc_offset) 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                  dtp->u.p.current_unit->strm_pos - 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->u.p.current_unit->strm_pos += (gfc_offset) 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                  dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
483         {
484           generate_error (&dtp->common, ERROR_OS, 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->u.p.current_unit->strm_pos += (gfc_offset) 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                  dtp->u.p.current_unit->strm_pos - 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->u.p.current_unit->strm_pos += (gfc_offset) 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->u.p.current_unit->strm_pos = 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 (!is_stream_io (dtp))
1770         {
1771           if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1772                      * dtp->u.p.current_unit->recl) == FAILURE)
1773             {
1774               generate_error (&dtp->common, ERROR_OS, NULL);
1775               return;
1776             }
1777         }
1778       else
1779         dtp->u.p.current_unit->strm_pos = dtp->rec;
1780
1781     }
1782
1783   /* Overwriting an existing sequential file ?
1784      it is always safe to truncate the file on the first write */
1785   if (dtp->u.p.mode == WRITING
1786       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1787       && dtp->u.p.current_unit->last_record == 0 
1788       && !is_preconnected(dtp->u.p.current_unit->s))
1789         struncate(dtp->u.p.current_unit->s);
1790
1791   /* Bugware for badly written mixed C-Fortran I/O.  */
1792   flush_if_preconnected(dtp->u.p.current_unit->s);
1793
1794   dtp->u.p.current_unit->mode = dtp->u.p.mode;
1795
1796   /* Set the initial value of flags.  */
1797
1798   dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1799   dtp->u.p.sign_status = SIGN_S;
1800
1801   pre_position (dtp);
1802
1803   /* Set up the subroutine that will handle the transfers.  */
1804
1805   if (read_flag)
1806     {
1807       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1808         dtp->u.p.transfer = unformatted_read;
1809       else
1810         {
1811           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1812             dtp->u.p.transfer = list_formatted_read;
1813           else
1814             dtp->u.p.transfer = formatted_transfer;
1815         }
1816     }
1817   else
1818     {
1819       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1820         dtp->u.p.transfer = unformatted_write;
1821       else
1822         {
1823           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1824             dtp->u.p.transfer = list_formatted_write;
1825           else
1826             dtp->u.p.transfer = formatted_transfer;
1827         }
1828     }
1829
1830   /* Make sure that we don't do a read after a nonadvancing write.  */
1831
1832   if (read_flag)
1833     {
1834       if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1835         {
1836           generate_error (&dtp->common, ERROR_BAD_OPTION,
1837                           "Cannot READ after a nonadvancing WRITE");
1838           return;
1839         }
1840     }
1841   else
1842     {
1843       if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1844         dtp->u.p.current_unit->read_bad = 1;
1845     }
1846
1847   /* Start the data transfer if we are doing a formatted transfer.  */
1848   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1849       && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1850       && dtp->u.p.ionml == NULL)
1851     formatted_transfer (dtp, 0, NULL, 0, 0, 1);
1852 }
1853
1854 /* Initialize an array_loop_spec given the array descriptor.  The function
1855    returns the index of the last element of the array.  */
1856    
1857 gfc_offset
1858 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1859 {
1860   int rank = GFC_DESCRIPTOR_RANK(desc);
1861   int i;
1862   gfc_offset index; 
1863
1864   index = 1;
1865   for (i=0; i<rank; i++)
1866     {
1867       ls[i].idx = 1;
1868       ls[i].start = desc->dim[i].lbound;
1869       ls[i].end = desc->dim[i].ubound;
1870       ls[i].step = desc->dim[i].stride;
1871       
1872       index += (desc->dim[i].ubound - desc->dim[i].lbound)
1873                       * desc->dim[i].stride;
1874     }
1875   return index;
1876 }
1877
1878 /* Determine the index to the next record in an internal unit array by
1879    by incrementing through the array_loop_spec.  TODO:  Implement handling
1880    negative strides. */
1881    
1882 gfc_offset
1883 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
1884 {
1885   int i, carry;
1886   gfc_offset index;
1887   
1888   carry = 1;
1889   index = 0;
1890   
1891   for (i = 0; i < dtp->u.p.current_unit->rank; i++)
1892     {
1893       if (carry)
1894         {
1895           ls[i].idx++;
1896           if (ls[i].idx > ls[i].end)
1897             {
1898               ls[i].idx = ls[i].start;
1899               carry = 1;
1900             }
1901           else
1902             carry = 0;
1903         }
1904       index = index + (ls[i].idx - 1) * ls[i].step;
1905     }
1906   return index;
1907 }
1908
1909 /* Space to the next record for read mode.  If the file is not
1910    seekable, we read MAX_READ chunks until we get to the right
1911    position.  */
1912
1913 #define MAX_READ 4096
1914
1915 static void
1916 next_record_r (st_parameter_dt *dtp)
1917 {
1918   gfc_offset new, record;
1919   int bytes_left, rlength, length;
1920   char *p;
1921
1922   switch (current_mode (dtp))
1923     {
1924     /* No records in STREAM I/O.  */
1925     case FORMATTED_STREAM:
1926     case UNFORMATTED_STREAM:
1927       return;
1928     
1929     case UNFORMATTED_SEQUENTIAL:
1930
1931       /* Skip over tail */
1932       dtp->u.p.current_unit->bytes_left +=
1933         compile_options.record_marker == 0 ?
1934         sizeof (gfc_offset) : compile_options.record_marker;
1935       
1936       /* Fall through...  */
1937
1938     case FORMATTED_DIRECT:
1939     case UNFORMATTED_DIRECT:
1940       if (dtp->u.p.current_unit->bytes_left == 0)
1941         break;
1942
1943       if (is_seekable (dtp->u.p.current_unit->s))
1944         {
1945           new = file_position (dtp->u.p.current_unit->s)
1946                 + dtp->u.p.current_unit->bytes_left;
1947
1948           /* Direct access files do not generate END conditions,
1949              only I/O errors.  */
1950           if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
1951             generate_error (&dtp->common, ERROR_OS, NULL);
1952
1953         }
1954       else
1955         {                       /* Seek by reading data.  */
1956           while (dtp->u.p.current_unit->bytes_left > 0)
1957             {
1958               rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
1959                 MAX_READ : dtp->u.p.current_unit->bytes_left;
1960
1961               p = salloc_r (dtp->u.p.current_unit->s, &rlength);
1962               if (p == NULL)
1963                 {
1964                   generate_error (&dtp->common, ERROR_OS, NULL);
1965                   break;
1966                 }
1967
1968               dtp->u.p.current_unit->bytes_left -= length;
1969             }
1970         }
1971       break;
1972
1973     case FORMATTED_SEQUENTIAL:
1974       length = 1;
1975       /* sf_read has already terminated input because of an '\n'  */
1976       if (dtp->u.p.sf_seen_eor)
1977         {
1978           dtp->u.p.sf_seen_eor = 0;
1979           break;
1980         }
1981
1982       if (is_internal_unit (dtp))
1983         {
1984           if (is_array_io (dtp))
1985             {
1986               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1987
1988               /* Now seek to this record.  */
1989               record = record * dtp->u.p.current_unit->recl;
1990               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1991                 {
1992                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
1993                   break;
1994                 }
1995               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1996             }
1997           else  
1998             {
1999               bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2000               p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2001               if (p != NULL)
2002                 dtp->u.p.current_unit->bytes_left
2003                   = dtp->u.p.current_unit->recl;
2004             } 
2005           break;
2006         }
2007       else do
2008         {
2009           p = salloc_r (dtp->u.p.current_unit->s, &length);
2010
2011           if (p == NULL)
2012             {
2013               generate_error (&dtp->common, ERROR_OS, NULL);
2014               break;
2015             }
2016
2017           if (length == 0)
2018             {
2019               dtp->u.p.current_unit->endfile = AT_ENDFILE;
2020               break;
2021             }
2022         }
2023       while (*p != '\n');
2024
2025       break;
2026     }
2027
2028   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2029     test_endfile (dtp->u.p.current_unit);
2030 }
2031
2032
2033 /* Small utility function to write a record marker, taking care of
2034    byte swapping and of choosing the correct size.  */
2035
2036 inline static int
2037 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2038 {
2039   size_t len;
2040   GFC_INTEGER_4 buf4;
2041   GFC_INTEGER_8 buf8;
2042   char p[sizeof (GFC_INTEGER_8)];
2043
2044   if (compile_options.record_marker == 0)
2045     len = sizeof (gfc_offset);
2046   else
2047     len = compile_options.record_marker;
2048
2049   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
2050   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2051     {
2052       switch (compile_options.record_marker)
2053         {
2054         case 0:
2055           return swrite (dtp->u.p.current_unit->s, &buf, &len);
2056           break;
2057
2058         case sizeof (GFC_INTEGER_4):
2059           buf4 = buf;
2060           return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2061           break;
2062
2063         case sizeof (GFC_INTEGER_8):
2064           buf8 = buf;
2065           return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2066           break;
2067
2068         default:
2069           runtime_error ("Illegal value for record marker");
2070           break;
2071         }
2072     }
2073   else
2074     {
2075       switch (compile_options.record_marker)
2076         {
2077         case 0:
2078           reverse_memcpy (p, &buf, sizeof (gfc_offset));
2079           return swrite (dtp->u.p.current_unit->s, p, &len);
2080           break;
2081
2082         case sizeof (GFC_INTEGER_4):
2083           buf4 = buf;
2084           reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2085           return swrite (dtp->u.p.current_unit->s, p, &len);
2086           break;
2087
2088         case sizeof (GFC_INTEGER_8):
2089           buf8 = buf;
2090           reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
2091           return swrite (dtp->u.p.current_unit->s, p, &len);
2092           break;
2093
2094         default:
2095           runtime_error ("Illegal value for record marker");
2096           break;
2097         }
2098     }
2099
2100 }
2101
2102
2103 /* Position to the next record in write mode.  */
2104
2105 static void
2106 next_record_w (st_parameter_dt *dtp, int done)
2107 {
2108   gfc_offset c, m, record, max_pos;
2109   int length;
2110   char *p;
2111   size_t record_marker;
2112
2113   /* Zero counters for X- and T-editing.  */
2114   max_pos = dtp->u.p.max_pos;
2115   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2116
2117   switch (current_mode (dtp))
2118     {
2119     /* No records in STREAM I/O.  */
2120     case FORMATTED_STREAM:
2121     case UNFORMATTED_STREAM:
2122       return;
2123
2124     case FORMATTED_DIRECT:
2125       if (dtp->u.p.current_unit->bytes_left == 0)
2126         break;
2127
2128       if (sset (dtp->u.p.current_unit->s, ' ', 
2129                 dtp->u.p.current_unit->bytes_left) == FAILURE)
2130         goto io_error;
2131
2132       break;
2133
2134     case UNFORMATTED_DIRECT:
2135       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2136         goto io_error;
2137       break;
2138
2139     case UNFORMATTED_SEQUENTIAL:
2140       /* Bytes written.  */
2141       m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
2142       c = file_position (dtp->u.p.current_unit->s);
2143
2144       /* Write the length tail.  */
2145
2146       if (write_us_marker (dtp, m) != 0)
2147         goto io_error;
2148
2149       if (compile_options.record_marker == 4)
2150         record_marker = sizeof(GFC_INTEGER_4);
2151       else
2152         record_marker = sizeof (gfc_offset);
2153
2154       /* Seek to the head and overwrite the bogus length with the real
2155          length.  */
2156
2157       if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2158           == FAILURE)
2159         goto io_error;
2160
2161       if (write_us_marker (dtp, m) != 0)
2162         goto io_error;
2163
2164       /* Seek past the end of the current record.  */
2165
2166       if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2167         goto io_error;
2168
2169       break;
2170
2171     case FORMATTED_SEQUENTIAL:
2172
2173       if (is_internal_unit (dtp))
2174         {
2175           if (is_array_io (dtp))
2176             {
2177               length = (int) dtp->u.p.current_unit->bytes_left;
2178               
2179               /* If the farthest position reached is greater than current
2180               position, adjust the position and set length to pad out
2181               whats left.  Otherwise just pad whats left.
2182               (for character array unit) */
2183               m = dtp->u.p.current_unit->recl
2184                         - dtp->u.p.current_unit->bytes_left;
2185               if (max_pos > m)
2186                 {
2187                   length = (int) (max_pos - m);
2188                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2189                   length = (int) (dtp->u.p.current_unit->recl - max_pos);
2190                 }
2191
2192               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2193                 {
2194                   generate_error (&dtp->common, ERROR_END, NULL);
2195                   return;
2196                 }
2197
2198               /* Now that the current record has been padded out,
2199                  determine where the next record in the array is. */
2200               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2201               if (record == 0)
2202                 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2203               
2204               /* Now seek to this record */
2205               record = record * dtp->u.p.current_unit->recl;
2206
2207               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2208                 {
2209                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2210                   return;
2211                 }
2212
2213               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2214             }
2215           else
2216             {
2217               length = 1;
2218
2219               /* If this is the last call to next_record move to the farthest
2220                  position reached and set length to pad out the remainder
2221                  of the record. (for character scaler unit) */
2222               if (done)
2223                 {
2224                   m = dtp->u.p.current_unit->recl
2225                         - dtp->u.p.current_unit->bytes_left;
2226                   if (max_pos > m)
2227                     {
2228                       length = (int) (max_pos - m);
2229                       p = salloc_w (dtp->u.p.current_unit->s, &length);
2230                       length = (int) (dtp->u.p.current_unit->recl - max_pos);
2231                     }
2232                   else
2233                     length = (int) dtp->u.p.current_unit->bytes_left;
2234                 }
2235               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2236                 {
2237                   generate_error (&dtp->common, ERROR_END, NULL);
2238                   return;
2239                 }
2240             }
2241         }
2242       else
2243         {
2244           if (dtp->u.p.current_unit->bytes_left == 0)
2245             break;
2246
2247           /* If this is the last call to next_record move to the farthest
2248           position reached in preparation for completing the record.
2249           (for file unit) */
2250           if (done)
2251             {
2252               m = dtp->u.p.current_unit->recl -
2253                         dtp->u.p.current_unit->bytes_left;
2254               if (max_pos > m)
2255                 {
2256                   length = (int) (max_pos - m);
2257                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2258                 }
2259             }
2260           size_t len;
2261           const char crlf[] = "\r\n";
2262 #ifdef HAVE_CRLF
2263           len = 2;
2264 #else
2265           len = 1;
2266 #endif
2267           if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2268             goto io_error;
2269         }
2270
2271       break;
2272
2273     io_error:
2274       generate_error (&dtp->common, ERROR_OS, NULL);
2275       break;
2276     }
2277 }
2278
2279 /* Position to the next record, which means moving to the end of the
2280    current record.  This can happen under several different
2281    conditions.  If the done flag is not set, we get ready to process
2282    the next record.  */
2283
2284 void
2285 next_record (st_parameter_dt *dtp, int done)
2286 {
2287   if (is_stream_io (dtp))
2288     return;
2289
2290   gfc_offset fp; /* File position.  */
2291
2292   dtp->u.p.current_unit->read_bad = 0;
2293
2294   if (dtp->u.p.mode == READING)
2295     next_record_r (dtp);
2296   else
2297     next_record_w (dtp, done);
2298
2299   /* keep position up to date for INQUIRE */
2300   dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2301   dtp->u.p.current_unit->current_record = 0;
2302   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2303    {
2304     fp = file_position (dtp->u.p.current_unit->s);
2305     /* Calculate next record, rounding up partial records.  */
2306     dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1)
2307                                 / dtp->u.p.current_unit->recl;
2308    }
2309   else
2310     dtp->u.p.current_unit->last_record++;
2311
2312   if (!done)
2313     pre_position (dtp);
2314 }
2315
2316
2317 /* Finalize the current data transfer.  For a nonadvancing transfer,
2318    this means advancing to the next record.  For internal units close the
2319    stream associated with the unit.  */
2320
2321 static void
2322 finalize_transfer (st_parameter_dt *dtp)
2323 {
2324   jmp_buf eof_jump;
2325   GFC_INTEGER_4 cf = dtp->common.flags;
2326
2327   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2328     *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
2329
2330   if (dtp->u.p.eor_condition)
2331     {
2332       generate_error (&dtp->common, ERROR_EOR, NULL);
2333       return;
2334     }
2335
2336   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2337     return;
2338
2339   if ((dtp->u.p.ionml != NULL)
2340       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2341     {
2342        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2343          namelist_read (dtp);
2344        else
2345          namelist_write (dtp);
2346     }
2347
2348   dtp->u.p.transfer = NULL;
2349   if (dtp->u.p.current_unit == NULL)
2350     return;
2351
2352   dtp->u.p.eof_jump = &eof_jump;
2353   if (setjmp (eof_jump))
2354     {
2355       generate_error (&dtp->common, ERROR_END, NULL);
2356       return;
2357     }
2358
2359   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2360     finish_list_read (dtp);
2361   else if (!is_stream_io (dtp))
2362     {
2363       dtp->u.p.current_unit->current_record = 0;
2364       if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
2365         {
2366           /* Most systems buffer lines, so force the partial record
2367              to be written out.  */
2368           if (!is_internal_unit (dtp))
2369             flush (dtp->u.p.current_unit->s);
2370           dtp->u.p.seen_dollar = 0;
2371           return;
2372         }
2373       next_record (dtp, 1);
2374     }
2375   else
2376     flush (dtp->u.p.current_unit->s);
2377
2378   sfree (dtp->u.p.current_unit->s);
2379 }
2380
2381 /* Transfer function for IOLENGTH. It doesn't actually do any
2382    data transfer, it just updates the length counter.  */
2383
2384 static void
2385 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), 
2386                    void *dest __attribute__ ((unused)),
2387                    int kind __attribute__((unused)), 
2388                    size_t size, size_t nelems)
2389 {
2390   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2391     *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2392 }
2393
2394
2395 /* Initialize the IOLENGTH data transfer. This function is in essence
2396    a very much simplified version of data_transfer_init(), because it
2397    doesn't have to deal with units at all.  */
2398
2399 static void
2400 iolength_transfer_init (st_parameter_dt *dtp)
2401 {
2402   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2403     *dtp->iolength = 0;
2404
2405   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2406
2407   /* Set up the subroutine that will handle the transfers.  */
2408
2409   dtp->u.p.transfer = iolength_transfer;
2410 }
2411
2412
2413 /* Library entry point for the IOLENGTH form of the INQUIRE
2414    statement. The IOLENGTH form requires no I/O to be performed, but
2415    it must still be a runtime library call so that we can determine
2416    the iolength for dynamic arrays and such.  */
2417
2418 extern void st_iolength (st_parameter_dt *);
2419 export_proto(st_iolength);
2420
2421 void
2422 st_iolength (st_parameter_dt *dtp)
2423 {
2424   library_start (&dtp->common);
2425   iolength_transfer_init (dtp);
2426 }
2427
2428 extern void st_iolength_done (st_parameter_dt *);
2429 export_proto(st_iolength_done);
2430
2431 void
2432 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2433 {
2434   free_ionml (dtp);
2435   if (dtp->u.p.scratch != NULL)
2436     free_mem (dtp->u.p.scratch);
2437   library_end ();
2438 }
2439
2440
2441 /* The READ statement.  */
2442
2443 extern void st_read (st_parameter_dt *);
2444 export_proto(st_read);
2445
2446 void
2447 st_read (st_parameter_dt *dtp)
2448 {
2449   library_start (&dtp->common);
2450
2451   data_transfer_init (dtp, 1);
2452
2453   /* Handle complications dealing with the endfile record.  It is
2454      significant that this is the only place where ERROR_END is
2455      generated.  Reading an end of file elsewhere is either end of
2456      record or an I/O error. */
2457
2458   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2459     switch (dtp->u.p.current_unit->endfile)
2460       {
2461       case NO_ENDFILE:
2462         break;
2463
2464       case AT_ENDFILE:
2465         if (!is_internal_unit (dtp))
2466           {
2467             generate_error (&dtp->common, ERROR_END, NULL);
2468             dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2469             dtp->u.p.current_unit->current_record = 0;
2470           }
2471         break;
2472
2473       case AFTER_ENDFILE:
2474         generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2475         dtp->u.p.current_unit->current_record = 0;
2476         break;
2477       }
2478 }
2479
2480 extern void st_read_done (st_parameter_dt *);
2481 export_proto(st_read_done);
2482
2483 void
2484 st_read_done (st_parameter_dt *dtp)
2485 {
2486   finalize_transfer (dtp);
2487   free_format_data (dtp);
2488   free_ionml (dtp);
2489   if (dtp->u.p.scratch != NULL)
2490     free_mem (dtp->u.p.scratch);
2491   if (dtp->u.p.current_unit != NULL)
2492     unlock_unit (dtp->u.p.current_unit);
2493
2494   free_internal_unit (dtp);
2495   
2496   library_end ();
2497 }
2498
2499 extern void st_write (st_parameter_dt *);
2500 export_proto(st_write);
2501
2502 void
2503 st_write (st_parameter_dt *dtp)
2504 {
2505   library_start (&dtp->common);
2506   data_transfer_init (dtp, 0);
2507 }
2508
2509 extern void st_write_done (st_parameter_dt *);
2510 export_proto(st_write_done);
2511
2512 void
2513 st_write_done (st_parameter_dt *dtp)
2514 {
2515   finalize_transfer (dtp);
2516
2517   /* Deal with endfile conditions associated with sequential files.  */
2518
2519   if (dtp->u.p.current_unit != NULL 
2520       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2521     switch (dtp->u.p.current_unit->endfile)
2522       {
2523       case AT_ENDFILE:          /* Remain at the endfile record.  */
2524         break;
2525
2526       case AFTER_ENDFILE:
2527         dtp->u.p.current_unit->endfile = AT_ENDFILE;    /* Just at it now.  */
2528         break;
2529
2530       case NO_ENDFILE:
2531         /* Get rid of whatever is after this record.  */
2532         if (!is_internal_unit (dtp))
2533           {
2534             flush (dtp->u.p.current_unit->s);
2535             if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2536               generate_error (&dtp->common, ERROR_OS, NULL);
2537           }
2538         dtp->u.p.current_unit->endfile = AT_ENDFILE;
2539         break;
2540       }
2541
2542   free_format_data (dtp);
2543   free_ionml (dtp);
2544   if (dtp->u.p.scratch != NULL)
2545     free_mem (dtp->u.p.scratch);
2546   if (dtp->u.p.current_unit != NULL)
2547     unlock_unit (dtp->u.p.current_unit);
2548   
2549   free_internal_unit (dtp);
2550
2551   library_end ();
2552 }
2553
2554 /* Receives the scalar information for namelist objects and stores it
2555    in a linked list of namelist_info types.  */
2556
2557 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2558                             GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2559 export_proto(st_set_nml_var);
2560
2561
2562 void
2563 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2564                 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2565                 GFC_INTEGER_4 dtype)
2566 {
2567   namelist_info *t1 = NULL;
2568   namelist_info *nml;
2569
2570   nml = (namelist_info*) get_mem (sizeof (namelist_info));
2571
2572   nml->mem_pos = var_addr;
2573
2574   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2575   strcpy (nml->var_name, var_name);
2576
2577   nml->len = (int) len;
2578   nml->string_length = (index_type) string_length;
2579
2580   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2581   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2582   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2583
2584   if (nml->var_rank > 0)
2585     {
2586       nml->dim = (descriptor_dimension*)
2587                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
2588       nml->ls = (array_loop_spec*)
2589                   get_mem (nml->var_rank * sizeof (array_loop_spec));
2590     }
2591   else
2592     {
2593       nml->dim = NULL;
2594       nml->ls = NULL;
2595     }
2596
2597   nml->next = NULL;
2598
2599   if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2600     {
2601       dtp->common.flags |= IOPARM_DT_IONML_SET;
2602       dtp->u.p.ionml = nml;
2603     }
2604   else
2605     {
2606       for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2607       t1->next = nml;
2608     }
2609 }
2610
2611 /* Store the dimensional information for the namelist object.  */
2612 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2613                                 GFC_INTEGER_4, GFC_INTEGER_4,
2614                                 GFC_INTEGER_4);
2615 export_proto(st_set_nml_var_dim);
2616
2617 void
2618 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2619                     GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2620                     GFC_INTEGER_4 ubound)
2621 {
2622   namelist_info * nml;
2623   int n;
2624
2625   n = (int)n_dim;
2626
2627   for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2628
2629   nml->dim[n].stride = (ssize_t)stride;
2630   nml->dim[n].lbound = (ssize_t)lbound;
2631   nml->dim[n].ubound = (ssize_t)ubound;
2632 }
2633
2634 /* Reverse memcpy - used for byte swapping.  */
2635
2636 void reverse_memcpy (void *dest, const void *src, size_t n)
2637 {
2638   char *d, *s;
2639   size_t i;
2640
2641   d = (char *) dest;
2642   s = (char *) src + n - 1;
2643
2644   /* Write with ascending order - this is likely faster
2645      on modern architectures because of write combining.  */
2646   for (i=0; i<n; i++)
2647       *(d++) = *(s--);
2648 }