OSDN Git Service

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