OSDN Git Service

aacf4a33ded56c6635ca6e313e4c7b2633054655
[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           if (require_type (dtp, BT_INTEGER, type, f))
848             return;
849
850           if (dtp->u.p.mode == READING)
851             read_radix (dtp, f, p, len, 2);
852           else
853             write_b (dtp, f, p, len);
854
855           break;
856
857         case FMT_O:
858           if (n == 0)
859             goto need_data;
860
861           if (dtp->u.p.mode == READING)
862             read_radix (dtp, f, p, len, 8);
863           else
864             write_o (dtp, f, p, len);
865
866           break;
867
868         case FMT_Z:
869           if (n == 0)
870             goto need_data;
871
872           if (dtp->u.p.mode == READING)
873             read_radix (dtp, f, p, len, 16);
874           else
875             write_z (dtp, f, p, len);
876
877           break;
878
879         case FMT_A:
880           if (n == 0)
881             goto need_data;
882
883           if (dtp->u.p.mode == READING)
884             read_a (dtp, f, p, len);
885           else
886             write_a (dtp, f, p, len);
887
888           break;
889
890         case FMT_L:
891           if (n == 0)
892             goto need_data;
893
894           if (dtp->u.p.mode == READING)
895             read_l (dtp, f, p, len);
896           else
897             write_l (dtp, f, p, len);
898
899           break;
900
901         case FMT_D:
902           if (n == 0)
903             goto need_data;
904           if (require_type (dtp, BT_REAL, type, f))
905             return;
906
907           if (dtp->u.p.mode == READING)
908             read_f (dtp, f, p, len);
909           else
910             write_d (dtp, f, p, len);
911
912           break;
913
914         case FMT_E:
915           if (n == 0)
916             goto need_data;
917           if (require_type (dtp, BT_REAL, type, f))
918             return;
919
920           if (dtp->u.p.mode == READING)
921             read_f (dtp, f, p, len);
922           else
923             write_e (dtp, f, p, len);
924           break;
925
926         case FMT_EN:
927           if (n == 0)
928             goto need_data;
929           if (require_type (dtp, BT_REAL, type, f))
930             return;
931
932           if (dtp->u.p.mode == READING)
933             read_f (dtp, f, p, len);
934           else
935             write_en (dtp, f, p, len);
936
937           break;
938
939         case FMT_ES:
940           if (n == 0)
941             goto need_data;
942           if (require_type (dtp, BT_REAL, type, f))
943             return;
944
945           if (dtp->u.p.mode == READING)
946             read_f (dtp, f, p, len);
947           else
948             write_es (dtp, f, p, len);
949
950           break;
951
952         case FMT_F:
953           if (n == 0)
954             goto need_data;
955           if (require_type (dtp, BT_REAL, type, f))
956             return;
957
958           if (dtp->u.p.mode == READING)
959             read_f (dtp, f, p, len);
960           else
961             write_f (dtp, f, p, len);
962
963           break;
964
965         case FMT_G:
966           if (n == 0)
967             goto need_data;
968           if (dtp->u.p.mode == READING)
969             switch (type)
970               {
971               case BT_INTEGER:
972                 read_decimal (dtp, f, p, len);
973                 break;
974               case BT_LOGICAL:
975                 read_l (dtp, f, p, len);
976                 break;
977               case BT_CHARACTER:
978                 read_a (dtp, f, p, len);
979                 break;
980               case BT_REAL:
981                 read_f (dtp, f, p, len);
982                 break;
983               default:
984                 goto bad_type;
985               }
986           else
987             switch (type)
988               {
989               case BT_INTEGER:
990                 write_i (dtp, f, p, len);
991                 break;
992               case BT_LOGICAL:
993                 write_l (dtp, f, p, len);
994                 break;
995               case BT_CHARACTER:
996                 write_a (dtp, f, p, len);
997                 break;
998               case BT_REAL:
999                 write_d (dtp, f, p, len);
1000                 break;
1001               default:
1002               bad_type:
1003                 internal_error (&dtp->common,
1004                                 "formatted_transfer(): Bad type");
1005               }
1006
1007           break;
1008
1009         case FMT_STRING:
1010           consume_data_flag = 0 ;
1011           if (dtp->u.p.mode == READING)
1012             {
1013               format_error (dtp, f, "Constant string in input format");
1014               return;
1015             }
1016           write_constant_string (dtp, f);
1017           break;
1018
1019         /* Format codes that don't transfer data.  */
1020         case FMT_X:
1021         case FMT_TR:
1022           consume_data_flag = 0 ;
1023
1024           pos = bytes_used + f->u.n + dtp->u.p.skips;
1025           dtp->u.p.skips = f->u.n + dtp->u.p.skips;
1026           dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
1027
1028           /* Writes occur just before the switch on f->format, above, so
1029              that trailing blanks are suppressed, unless we are doing a
1030              non-advancing write in which case we want to output the blanks
1031              now.  */
1032           if (dtp->u.p.mode == WRITING
1033               && dtp->u.p.advance_status == ADVANCE_NO)
1034             {
1035               write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1036               dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1037             }
1038           if (dtp->u.p.mode == READING)
1039             read_x (dtp, f->u.n);
1040
1041           break;
1042
1043         case FMT_TL:
1044         case FMT_T:
1045           if (f->format == FMT_TL)
1046             {
1047
1048               /* Handle the special case when no bytes have been used yet.
1049                  Cannot go below zero. */
1050               if (bytes_used == 0)
1051                 {
1052                   dtp->u.p.pending_spaces -= f->u.n;
1053                   dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
1054                                             : dtp->u.p.pending_spaces;
1055                   dtp->u.p.skips -= f->u.n;
1056                   dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1057                 }
1058
1059               pos = bytes_used - f->u.n;
1060             }
1061           else /* FMT_T */
1062             {
1063               consume_data_flag = 0;
1064               pos = f->u.n - 1;
1065             }
1066
1067           /* Standard 10.6.1.1: excessive left tabbing is reset to the
1068              left tab limit.  We do not check if the position has gone
1069              beyond the end of record because a subsequent tab could
1070              bring us back again.  */
1071           pos = pos < 0 ? 0 : pos;
1072
1073           dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1074           dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1075                                     + pos - dtp->u.p.max_pos;
1076
1077           if (dtp->u.p.skips == 0)
1078             break;
1079
1080           /* Writes occur just before the switch on f->format, above, so that
1081              trailing blanks are suppressed.  */
1082           if (dtp->u.p.mode == READING)
1083             {
1084               /* Adjust everything for end-of-record condition */
1085               if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1086                 {
1087                   if (dtp->u.p.sf_seen_eor == 2)
1088                     {
1089                       /* The EOR was a CRLF (two bytes wide).  */
1090                       dtp->u.p.current_unit->bytes_left -= 2;
1091                       dtp->u.p.skips -= 2;
1092                     }
1093                   else
1094                     {
1095                       /* The EOR marker was only one byte wide.  */
1096                       dtp->u.p.current_unit->bytes_left--;
1097                       dtp->u.p.skips--;
1098                     }
1099                   bytes_used = pos;
1100                   dtp->u.p.sf_seen_eor = 0;
1101                 }
1102               if (dtp->u.p.skips < 0)
1103                 {
1104                   move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1105                   dtp->u.p.current_unit->bytes_left
1106                     -= (gfc_offset) dtp->u.p.skips;
1107                   dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1108                 }
1109               else
1110                 read_x (dtp, dtp->u.p.skips);
1111             }
1112
1113           break;
1114
1115         case FMT_S:
1116           consume_data_flag = 0 ;
1117           dtp->u.p.sign_status = SIGN_S;
1118           break;
1119
1120         case FMT_SS:
1121           consume_data_flag = 0 ;
1122           dtp->u.p.sign_status = SIGN_SS;
1123           break;
1124
1125         case FMT_SP:
1126           consume_data_flag = 0 ;
1127           dtp->u.p.sign_status = SIGN_SP;
1128           break;
1129
1130         case FMT_BN:
1131           consume_data_flag = 0 ;
1132           dtp->u.p.blank_status = BLANK_NULL;
1133           break;
1134
1135         case FMT_BZ:
1136           consume_data_flag = 0 ;
1137           dtp->u.p.blank_status = BLANK_ZERO;
1138           break;
1139
1140         case FMT_P:
1141           consume_data_flag = 0 ;
1142           dtp->u.p.scale_factor = f->u.k;
1143           break;
1144
1145         case FMT_DOLLAR:
1146           consume_data_flag = 0 ;
1147           dtp->u.p.seen_dollar = 1;
1148           break;
1149
1150         case FMT_SLASH:
1151           consume_data_flag = 0 ;
1152           dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1153           next_record (dtp, 0);
1154           break;
1155
1156         case FMT_COLON:
1157           /* A colon descriptor causes us to exit this loop (in
1158              particular preventing another / descriptor from being
1159              processed) unless there is another data item to be
1160              transferred.  */
1161           consume_data_flag = 0 ;
1162           if (n == 0)
1163             return;
1164           break;
1165
1166         default:
1167           internal_error (&dtp->common, "Bad format node");
1168         }
1169
1170       /* Free a buffer that we had to allocate during a sequential
1171          formatted read of a block that was larger than the static
1172          buffer.  */
1173
1174       if (dtp->u.p.line_buffer != scratch)
1175         {
1176           free_mem (dtp->u.p.line_buffer);
1177           dtp->u.p.line_buffer = scratch;
1178         }
1179
1180       /* Adjust the item count and data pointer.  */
1181
1182       if ((consume_data_flag > 0) && (n > 0))
1183       {
1184         n--;
1185         p = ((char *) p) + size;
1186       }
1187
1188       if (dtp->u.p.mode == READING)
1189         dtp->u.p.skips = 0;
1190
1191       pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1192       dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1193
1194     }
1195
1196   return;
1197
1198   /* Come here when we need a data descriptor but don't have one.  We
1199      push the current format node back onto the input, then return and
1200      let the user program call us back with the data.  */
1201  need_data:
1202   unget_format (dtp, f);
1203 }
1204
1205 static void
1206 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1207                     size_t size, size_t nelems)
1208 {
1209   size_t elem;
1210   char *tmp;
1211
1212   tmp = (char *) p;
1213
1214   /* Big loop over all the elements.  */
1215   for (elem = 0; elem < nelems; elem++)
1216     {
1217       dtp->u.p.item_count++;
1218       formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1219     }
1220 }
1221
1222
1223
1224 /* Data transfer entry points.  The type of the data entity is
1225    implicit in the subroutine call.  This prevents us from having to
1226    share a common enum with the compiler.  */
1227
1228 void
1229 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1230 {
1231   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1232     return;
1233   dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1234 }
1235
1236
1237 void
1238 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1239 {
1240   size_t size;
1241   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1242     return;
1243   size = size_from_real_kind (kind);
1244   dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1245 }
1246
1247
1248 void
1249 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1250 {
1251   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1252     return;
1253   dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1254 }
1255
1256
1257 void
1258 transfer_character (st_parameter_dt *dtp, void *p, int len)
1259 {
1260   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1261     return;
1262   /* Currently we support only 1 byte chars, and the library is a bit
1263      confused of character kind vs. length, so we kludge it by setting
1264      kind = length.  */
1265   dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1266 }
1267
1268
1269 void
1270 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1271 {
1272   size_t size;
1273   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1274     return;
1275   size = size_from_complex_kind (kind);
1276   dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1277 }
1278
1279
1280 void
1281 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1282                 gfc_charlen_type charlen)
1283 {
1284   index_type count[GFC_MAX_DIMENSIONS];
1285   index_type extent[GFC_MAX_DIMENSIONS];
1286   index_type stride[GFC_MAX_DIMENSIONS];
1287   index_type stride0, rank, size, type, n;
1288   size_t tsize;
1289   char *data;
1290   bt iotype;
1291
1292   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1293     return;
1294
1295   type = GFC_DESCRIPTOR_TYPE (desc);
1296   size = GFC_DESCRIPTOR_SIZE (desc);
1297
1298   /* FIXME: What a kludge: Array descriptors and the IO library use
1299      different enums for types.  */
1300   switch (type)
1301     {
1302     case GFC_DTYPE_UNKNOWN:
1303       iotype = BT_NULL;  /* Is this correct?  */
1304       break;
1305     case GFC_DTYPE_INTEGER:
1306       iotype = BT_INTEGER;
1307       break;
1308     case GFC_DTYPE_LOGICAL:
1309       iotype = BT_LOGICAL;
1310       break;
1311     case GFC_DTYPE_REAL:
1312       iotype = BT_REAL;
1313       break;
1314     case GFC_DTYPE_COMPLEX:
1315       iotype = BT_COMPLEX;
1316       break;
1317     case GFC_DTYPE_CHARACTER:
1318       iotype = BT_CHARACTER;
1319       /* FIXME: Currently dtype contains the charlen, which is
1320          clobbered if charlen > 2**24. That's why we use a separate
1321          argument for the charlen. However, if we want to support
1322          non-8-bit charsets we need to fix dtype to contain
1323          sizeof(chartype) and fix the code below.  */
1324       size = charlen;
1325       kind = charlen;
1326       break;
1327     case GFC_DTYPE_DERIVED:
1328       internal_error (&dtp->common,
1329                 "Derived type I/O should have been handled via the frontend.");
1330       break;
1331     default:
1332       internal_error (&dtp->common, "transfer_array(): Bad type");
1333     }
1334
1335   rank = GFC_DESCRIPTOR_RANK (desc);
1336   for (n = 0; n < rank; n++)
1337     {
1338       count[n] = 0;
1339       stride[n] = desc->dim[n].stride;
1340       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1341
1342       /* If the extent of even one dimension is zero, then the entire
1343          array section contains zero elements, so we return.  */
1344       if (extent[n] == 0)
1345         return;
1346     }
1347
1348   stride0 = stride[0];
1349
1350   /* If the innermost dimension has stride 1, we can do the transfer
1351      in contiguous chunks.  */
1352   if (stride0 == 1)
1353     tsize = extent[0];
1354   else
1355     tsize = 1;
1356
1357   data = GFC_DESCRIPTOR_DATA (desc);
1358
1359   while (data)
1360     {
1361       dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1362       data += stride0 * size * tsize;
1363       count[0] += tsize;
1364       n = 0;
1365       while (count[n] == extent[n])
1366         {
1367           count[n] = 0;
1368           data -= stride[n] * extent[n] * size;
1369           n++;
1370           if (n == rank)
1371             {
1372               data = NULL;
1373               break;
1374             }
1375           else
1376             {
1377               count[n]++;
1378               data += stride[n] * size;
1379             }
1380         }
1381     }
1382 }
1383
1384
1385 /* Preposition a sequential unformatted file while reading.  */
1386
1387 static void
1388 us_read (st_parameter_dt *dtp)
1389 {
1390   char *p;
1391   int n;
1392   int nr;
1393   GFC_INTEGER_4 i4;
1394   GFC_INTEGER_8 i8;
1395   gfc_offset i;
1396
1397   if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1398     return;
1399
1400   if (compile_options.record_marker == 0)
1401     n = sizeof (gfc_offset);
1402   else
1403     n = compile_options.record_marker;
1404
1405   nr = n;
1406
1407   p = salloc_r (dtp->u.p.current_unit->s, &n);
1408
1409   if (n == 0)
1410     {
1411       dtp->u.p.current_unit->endfile = AT_ENDFILE;
1412       return;  /* end of file */
1413     }
1414
1415   if (p == NULL || n != nr)
1416     {
1417       generate_error (&dtp->common, ERROR_BAD_US, NULL);
1418       return;
1419     }
1420
1421   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
1422   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1423     {
1424       switch (compile_options.record_marker)
1425         {
1426         case 0:
1427           memcpy (&i, p, sizeof(gfc_offset));
1428           break;
1429
1430         case sizeof(GFC_INTEGER_4):
1431           memcpy (&i4, p, sizeof (i4));
1432           i = i4;
1433           break;
1434
1435         case sizeof(GFC_INTEGER_8):
1436           memcpy (&i8, p, sizeof (i8));
1437           i = i8;
1438           break;
1439
1440         default:
1441           runtime_error ("Illegal value for record marker");
1442           break;
1443         }
1444     }
1445   else
1446       switch (compile_options.record_marker)
1447         {
1448         case 0:
1449           reverse_memcpy (&i, p, sizeof(gfc_offset));
1450           break;
1451
1452         case sizeof(GFC_INTEGER_4):
1453           reverse_memcpy (&i4, p, sizeof (i4));
1454           i = i4;
1455           break;
1456
1457         case sizeof(GFC_INTEGER_8):
1458           reverse_memcpy (&i8, p, sizeof (i8));
1459           i = i8;
1460           break;
1461
1462         default:
1463           runtime_error ("Illegal value for record marker");
1464           break;
1465         }
1466
1467   dtp->u.p.current_unit->bytes_left = i;
1468 }
1469
1470
1471 /* Preposition a sequential unformatted file while writing.  This
1472    amount to writing a bogus length that will be filled in later.  */
1473
1474 static void
1475 us_write (st_parameter_dt *dtp)
1476 {
1477   size_t nbytes;
1478   gfc_offset dummy;
1479
1480   dummy = 0;
1481
1482   if (compile_options.record_marker == 0)
1483     nbytes = sizeof (gfc_offset);
1484   else
1485     nbytes = compile_options.record_marker ;
1486
1487   if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1488     generate_error (&dtp->common, ERROR_OS, NULL);
1489
1490   /* For sequential unformatted, we write until we have more bytes
1491      than can fit in the record markers. If disk space runs out first,
1492      it will error on the write.  */
1493   dtp->u.p.current_unit->recl = max_offset;
1494
1495   dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1496 }
1497
1498
1499 /* Position to the next record prior to transfer.  We are assumed to
1500    be before the next record.  We also calculate the bytes in the next
1501    record.  */
1502
1503 static void
1504 pre_position (st_parameter_dt *dtp)
1505 {
1506   if (dtp->u.p.current_unit->current_record)
1507     return;                     /* Already positioned.  */
1508
1509   switch (current_mode (dtp))
1510     {
1511     case FORMATTED_STREAM:
1512     case UNFORMATTED_STREAM:
1513       /* There are no records with stream I/O.  Set the default position
1514          to the beginning of the file if no position was specified.  */
1515       if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1516         dtp->u.p.current_unit->strm_pos = 1;
1517       break;
1518     
1519     case UNFORMATTED_SEQUENTIAL:
1520       if (dtp->u.p.mode == READING)
1521         us_read (dtp);
1522       else
1523         us_write (dtp);
1524
1525       break;
1526
1527     case FORMATTED_SEQUENTIAL:
1528     case FORMATTED_DIRECT:
1529     case UNFORMATTED_DIRECT:
1530       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1531       break;
1532     }
1533
1534   dtp->u.p.current_unit->current_record = 1;
1535 }
1536
1537
1538 /* Initialize things for a data transfer.  This code is common for
1539    both reading and writing.  */
1540
1541 static void
1542 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1543 {
1544   unit_flags u_flags;  /* Used for creating a unit if needed.  */
1545   GFC_INTEGER_4 cf = dtp->common.flags;
1546   namelist_info *ionml;
1547
1548   ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1549   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1550   dtp->u.p.ionml = ionml;
1551   dtp->u.p.mode = read_flag ? READING : WRITING;
1552
1553   if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1554     dtp->u.p.size_used = 0;  /* Initialize the count.  */
1555
1556   dtp->u.p.current_unit = get_unit (dtp, 1);
1557   if (dtp->u.p.current_unit->s == NULL)
1558   {  /* Open the unit with some default flags.  */
1559      st_parameter_open opp;
1560      unit_convert conv;
1561
1562      if (dtp->common.unit < 0)
1563      {
1564        close_unit (dtp->u.p.current_unit);
1565        dtp->u.p.current_unit = NULL;
1566        generate_error (&dtp->common, ERROR_BAD_OPTION,
1567                        "Bad unit number in OPEN statement");
1568        return;
1569      }
1570      memset (&u_flags, '\0', sizeof (u_flags));
1571      u_flags.access = ACCESS_SEQUENTIAL;
1572      u_flags.action = ACTION_READWRITE;
1573
1574      /* Is it unformatted?  */
1575      if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1576                  | IOPARM_DT_IONML_SET)))
1577        u_flags.form = FORM_UNFORMATTED;
1578      else
1579        u_flags.form = FORM_UNSPECIFIED;
1580
1581      u_flags.delim = DELIM_UNSPECIFIED;
1582      u_flags.blank = BLANK_UNSPECIFIED;
1583      u_flags.pad = PAD_UNSPECIFIED;
1584      u_flags.status = STATUS_UNKNOWN;
1585
1586      conv = get_unformatted_convert (dtp->common.unit);
1587
1588      if (conv == CONVERT_NONE)
1589        conv = compile_options.convert;
1590
1591      /* We use l8_to_l4_offset, which is 0 on little-endian machines
1592         and 1 on big-endian machines.  */
1593      switch (conv)
1594        {
1595        case CONVERT_NATIVE:
1596        case CONVERT_SWAP:
1597          break;
1598          
1599        case CONVERT_BIG:
1600          conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1601          break;
1602       
1603        case CONVERT_LITTLE:
1604          conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1605          break;
1606          
1607        default:
1608          internal_error (&opp.common, "Illegal value for CONVERT");
1609          break;
1610        }
1611
1612      u_flags.convert = conv;
1613
1614      opp.common = dtp->common;
1615      opp.common.flags &= IOPARM_COMMON_MASK;
1616      dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1617      dtp->common.flags &= ~IOPARM_COMMON_MASK;
1618      dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1619      if (dtp->u.p.current_unit == NULL)
1620        return;
1621   }
1622
1623   /* Check the action.  */
1624
1625   if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1626     generate_error (&dtp->common, ERROR_BAD_ACTION,
1627                     "Cannot read from file opened for WRITE");
1628
1629   if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1630     generate_error (&dtp->common, ERROR_BAD_ACTION,
1631                     "Cannot write to file opened for READ");
1632
1633   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1634     return;
1635
1636   dtp->u.p.first_item = 1;
1637
1638   /* Check the format.  */
1639
1640   if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1641     parse_format (dtp);
1642
1643   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1644     return;
1645
1646   if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1647       && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1648          != 0)
1649     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1650                     "Format present for UNFORMATTED data transfer");
1651
1652   if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1653      {
1654         if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1655            generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1656                     "A format cannot be specified with a namelist");
1657      }
1658   else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1659            !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1660     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1661                     "Missing format for FORMATTED data transfer");
1662
1663   if (is_internal_unit (dtp)
1664       && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1665     generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1666                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1667
1668   /* Check the record or position number.  */
1669
1670   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1671       && (cf & IOPARM_DT_HAS_REC) == 0)
1672     {
1673       generate_error (&dtp->common, ERROR_MISSING_OPTION,
1674                       "Direct access data transfer requires record number");
1675       return;
1676     }
1677
1678   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1679       && (cf & IOPARM_DT_HAS_REC) != 0)
1680     {
1681       generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1682                       "Record number not allowed for sequential access data transfer");
1683       return;
1684     }
1685
1686   /* Process the ADVANCE option.  */
1687
1688   dtp->u.p.advance_status
1689     = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1690       find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1691                    "Bad ADVANCE parameter in data transfer statement");
1692
1693   if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1694     {
1695       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1696         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1697                         "ADVANCE specification conflicts with sequential access");
1698
1699       if (is_internal_unit (dtp))
1700         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1701                         "ADVANCE specification conflicts with internal file");
1702
1703       if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1704           != IOPARM_DT_HAS_FORMAT)
1705         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1706                         "ADVANCE specification requires an explicit format");
1707     }
1708
1709   if (read_flag)
1710     {
1711       if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1712         generate_error (&dtp->common, ERROR_MISSING_OPTION,
1713                         "EOR specification requires an ADVANCE specification of NO");
1714
1715       if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1716         generate_error (&dtp->common, ERROR_MISSING_OPTION,
1717                         "SIZE specification requires an ADVANCE specification of NO");
1718
1719     }
1720   else
1721     {                           /* Write constraints.  */
1722       if ((cf & IOPARM_END) != 0)
1723         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1724                         "END specification cannot appear in a write statement");
1725
1726       if ((cf & IOPARM_EOR) != 0)
1727         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1728                         "EOR specification cannot appear in a write statement");
1729
1730       if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1731         generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1732                         "SIZE specification cannot appear in a write statement");
1733     }
1734
1735   if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1736     dtp->u.p.advance_status = ADVANCE_YES;
1737   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1738     return;
1739
1740   /* Sanity checks on the record number.  */
1741   if ((cf & IOPARM_DT_HAS_REC) != 0)
1742     {
1743       if (dtp->rec <= 0)
1744         {
1745           generate_error (&dtp->common, ERROR_BAD_OPTION,
1746                           "Record number must be positive");
1747           return;
1748         }
1749
1750       if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1751         {
1752           generate_error (&dtp->common, ERROR_BAD_OPTION,
1753                           "Record number too large");
1754           return;
1755         }
1756
1757       /* Check to see if we might be reading what we wrote before  */
1758
1759       if (dtp->u.p.mode == READING
1760           && dtp->u.p.current_unit->mode == WRITING
1761           && !is_internal_unit (dtp))
1762          flush(dtp->u.p.current_unit->s);
1763
1764       /* Check whether the record exists to be read.  Only
1765          a partial record needs to exist.  */
1766
1767       if (dtp->u.p.mode == READING && (dtp->rec -1)
1768           * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1769         {
1770           generate_error (&dtp->common, ERROR_BAD_OPTION,
1771                           "Non-existing record number");
1772           return;
1773         }
1774
1775       /* Position the file.  */
1776       if (!is_stream_io (dtp))
1777         {
1778           if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1779                      * dtp->u.p.current_unit->recl) == FAILURE)
1780             {
1781               generate_error (&dtp->common, ERROR_OS, NULL);
1782               return;
1783             }
1784         }
1785       else
1786         dtp->u.p.current_unit->strm_pos = dtp->rec;
1787
1788     }
1789
1790   /* Overwriting an existing sequential file ?
1791      it is always safe to truncate the file on the first write */
1792   if (dtp->u.p.mode == WRITING
1793       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1794       && dtp->u.p.current_unit->last_record == 0 
1795       && !is_preconnected(dtp->u.p.current_unit->s))
1796         struncate(dtp->u.p.current_unit->s);
1797
1798   /* Bugware for badly written mixed C-Fortran I/O.  */
1799   flush_if_preconnected(dtp->u.p.current_unit->s);
1800
1801   dtp->u.p.current_unit->mode = dtp->u.p.mode;
1802
1803   /* Set the initial value of flags.  */
1804
1805   dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1806   dtp->u.p.sign_status = SIGN_S;
1807
1808   pre_position (dtp);
1809
1810   /* Set up the subroutine that will handle the transfers.  */
1811
1812   if (read_flag)
1813     {
1814       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1815         dtp->u.p.transfer = unformatted_read;
1816       else
1817         {
1818           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1819             dtp->u.p.transfer = list_formatted_read;
1820           else
1821             dtp->u.p.transfer = formatted_transfer;
1822         }
1823     }
1824   else
1825     {
1826       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1827         dtp->u.p.transfer = unformatted_write;
1828       else
1829         {
1830           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1831             dtp->u.p.transfer = list_formatted_write;
1832           else
1833             dtp->u.p.transfer = formatted_transfer;
1834         }
1835     }
1836
1837   /* Make sure that we don't do a read after a nonadvancing write.  */
1838
1839   if (read_flag)
1840     {
1841       if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1842         {
1843           generate_error (&dtp->common, ERROR_BAD_OPTION,
1844                           "Cannot READ after a nonadvancing WRITE");
1845           return;
1846         }
1847     }
1848   else
1849     {
1850       if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1851         dtp->u.p.current_unit->read_bad = 1;
1852     }
1853
1854   /* Start the data transfer if we are doing a formatted transfer.  */
1855   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1856       && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1857       && dtp->u.p.ionml == NULL)
1858     formatted_transfer (dtp, 0, NULL, 0, 0, 1);
1859 }
1860
1861 /* Initialize an array_loop_spec given the array descriptor.  The function
1862    returns the index of the last element of the array.  */
1863    
1864 gfc_offset
1865 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1866 {
1867   int rank = GFC_DESCRIPTOR_RANK(desc);
1868   int i;
1869   gfc_offset index; 
1870
1871   index = 1;
1872   for (i=0; i<rank; i++)
1873     {
1874       ls[i].idx = 1;
1875       ls[i].start = desc->dim[i].lbound;
1876       ls[i].end = desc->dim[i].ubound;
1877       ls[i].step = desc->dim[i].stride;
1878       
1879       index += (desc->dim[i].ubound - desc->dim[i].lbound)
1880                       * desc->dim[i].stride;
1881     }
1882   return index;
1883 }
1884
1885 /* Determine the index to the next record in an internal unit array by
1886    by incrementing through the array_loop_spec.  TODO:  Implement handling
1887    negative strides. */
1888    
1889 gfc_offset
1890 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
1891 {
1892   int i, carry;
1893   gfc_offset index;
1894   
1895   carry = 1;
1896   index = 0;
1897   
1898   for (i = 0; i < dtp->u.p.current_unit->rank; i++)
1899     {
1900       if (carry)
1901         {
1902           ls[i].idx++;
1903           if (ls[i].idx > ls[i].end)
1904             {
1905               ls[i].idx = ls[i].start;
1906               carry = 1;
1907             }
1908           else
1909             carry = 0;
1910         }
1911       index = index + (ls[i].idx - 1) * ls[i].step;
1912     }
1913   return index;
1914 }
1915
1916 /* Space to the next record for read mode.  If the file is not
1917    seekable, we read MAX_READ chunks until we get to the right
1918    position.  */
1919
1920 #define MAX_READ 4096
1921
1922 static void
1923 next_record_r (st_parameter_dt *dtp)
1924 {
1925   gfc_offset new, record;
1926   int bytes_left, rlength, length;
1927   char *p;
1928
1929   switch (current_mode (dtp))
1930     {
1931     /* No records in unformatted STREAM I/O.  */
1932     case UNFORMATTED_STREAM:
1933       return;
1934     
1935     case UNFORMATTED_SEQUENTIAL:
1936
1937       /* Skip over tail */
1938       dtp->u.p.current_unit->bytes_left +=
1939         compile_options.record_marker == 0 ?
1940         sizeof (gfc_offset) : compile_options.record_marker;
1941       
1942       /* Fall through...  */
1943
1944     case FORMATTED_DIRECT:
1945     case UNFORMATTED_DIRECT:
1946       if (dtp->u.p.current_unit->bytes_left == 0)
1947         break;
1948
1949       if (is_seekable (dtp->u.p.current_unit->s))
1950         {
1951           new = file_position (dtp->u.p.current_unit->s)
1952                 + dtp->u.p.current_unit->bytes_left;
1953
1954           /* Direct access files do not generate END conditions,
1955              only I/O errors.  */
1956           if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
1957             generate_error (&dtp->common, ERROR_OS, NULL);
1958
1959         }
1960       else
1961         {                       /* Seek by reading data.  */
1962           while (dtp->u.p.current_unit->bytes_left > 0)
1963             {
1964               rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
1965                 MAX_READ : dtp->u.p.current_unit->bytes_left;
1966
1967               p = salloc_r (dtp->u.p.current_unit->s, &rlength);
1968               if (p == NULL)
1969                 {
1970                   generate_error (&dtp->common, ERROR_OS, NULL);
1971                   break;
1972                 }
1973
1974               dtp->u.p.current_unit->bytes_left -= length;
1975             }
1976         }
1977       break;
1978
1979     case FORMATTED_STREAM:
1980     case FORMATTED_SEQUENTIAL:
1981       length = 1;
1982       /* sf_read has already terminated input because of an '\n'  */
1983       if (dtp->u.p.sf_seen_eor)
1984         {
1985           dtp->u.p.sf_seen_eor = 0;
1986           break;
1987         }
1988
1989       if (is_internal_unit (dtp))
1990         {
1991           if (is_array_io (dtp))
1992             {
1993               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1994
1995               /* Now seek to this record.  */
1996               record = record * dtp->u.p.current_unit->recl;
1997               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1998                 {
1999                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2000                   break;
2001                 }
2002               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2003             }
2004           else  
2005             {
2006               bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2007               p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2008               if (p != NULL)
2009                 dtp->u.p.current_unit->bytes_left
2010                   = dtp->u.p.current_unit->recl;
2011             } 
2012           break;
2013         }
2014       else do
2015         {
2016           p = salloc_r (dtp->u.p.current_unit->s, &length);
2017
2018           if (p == NULL)
2019             {
2020               generate_error (&dtp->common, ERROR_OS, NULL);
2021               break;
2022             }
2023
2024           if (length == 0)
2025             {
2026               dtp->u.p.current_unit->endfile = AT_ENDFILE;
2027               break;
2028             }
2029
2030           if (is_stream_io (dtp))
2031             dtp->u.p.current_unit->strm_pos++;
2032         }
2033       while (*p != '\n');
2034
2035       break;
2036     }
2037
2038   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2039     test_endfile (dtp->u.p.current_unit);
2040 }
2041
2042
2043 /* Small utility function to write a record marker, taking care of
2044    byte swapping and of choosing the correct size.  */
2045
2046 inline static int
2047 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2048 {
2049   size_t len;
2050   GFC_INTEGER_4 buf4;
2051   GFC_INTEGER_8 buf8;
2052   char p[sizeof (GFC_INTEGER_8)];
2053
2054   if (compile_options.record_marker == 0)
2055     len = sizeof (gfc_offset);
2056   else
2057     len = compile_options.record_marker;
2058
2059   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
2060   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2061     {
2062       switch (compile_options.record_marker)
2063         {
2064         case 0:
2065           return swrite (dtp->u.p.current_unit->s, &buf, &len);
2066           break;
2067
2068         case sizeof (GFC_INTEGER_4):
2069           buf4 = buf;
2070           return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2071           break;
2072
2073         case sizeof (GFC_INTEGER_8):
2074           buf8 = buf;
2075           return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2076           break;
2077
2078         default:
2079           runtime_error ("Illegal value for record marker");
2080           break;
2081         }
2082     }
2083   else
2084     {
2085       switch (compile_options.record_marker)
2086         {
2087         case 0:
2088           reverse_memcpy (p, &buf, sizeof (gfc_offset));
2089           return swrite (dtp->u.p.current_unit->s, p, &len);
2090           break;
2091
2092         case sizeof (GFC_INTEGER_4):
2093           buf4 = buf;
2094           reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2095           return swrite (dtp->u.p.current_unit->s, p, &len);
2096           break;
2097
2098         case sizeof (GFC_INTEGER_8):
2099           buf8 = buf;
2100           reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
2101           return swrite (dtp->u.p.current_unit->s, p, &len);
2102           break;
2103
2104         default:
2105           runtime_error ("Illegal value for record marker");
2106           break;
2107         }
2108     }
2109
2110 }
2111
2112
2113 /* Position to the next record in write mode.  */
2114
2115 static void
2116 next_record_w (st_parameter_dt *dtp, int done)
2117 {
2118   gfc_offset c, m, record, max_pos;
2119   int length;
2120   char *p;
2121   size_t record_marker;
2122
2123   /* Zero counters for X- and T-editing.  */
2124   max_pos = dtp->u.p.max_pos;
2125   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2126
2127   switch (current_mode (dtp))
2128     {
2129     /* No records in unformatted STREAM I/O.  */
2130     case UNFORMATTED_STREAM:
2131       return;
2132
2133     case FORMATTED_DIRECT:
2134       if (dtp->u.p.current_unit->bytes_left == 0)
2135         break;
2136
2137       if (sset (dtp->u.p.current_unit->s, ' ', 
2138                 dtp->u.p.current_unit->bytes_left) == FAILURE)
2139         goto io_error;
2140
2141       break;
2142
2143     case UNFORMATTED_DIRECT:
2144       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2145         goto io_error;
2146       break;
2147
2148     case UNFORMATTED_SEQUENTIAL:
2149       /* Bytes written.  */
2150       m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
2151       c = file_position (dtp->u.p.current_unit->s);
2152
2153       /* Write the length tail.  */
2154
2155       if (write_us_marker (dtp, m) != 0)
2156         goto io_error;
2157
2158       if (compile_options.record_marker == 4)
2159         record_marker = sizeof(GFC_INTEGER_4);
2160       else
2161         record_marker = sizeof (gfc_offset);
2162
2163       /* Seek to the head and overwrite the bogus length with the real
2164          length.  */
2165
2166       if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2167           == FAILURE)
2168         goto io_error;
2169
2170       if (write_us_marker (dtp, m) != 0)
2171         goto io_error;
2172
2173       /* Seek past the end of the current record.  */
2174
2175       if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2176         goto io_error;
2177
2178       break;
2179
2180     case FORMATTED_STREAM:
2181     case FORMATTED_SEQUENTIAL:
2182
2183       if (is_internal_unit (dtp))
2184         {
2185           if (is_array_io (dtp))
2186             {
2187               length = (int) dtp->u.p.current_unit->bytes_left;
2188               
2189               /* If the farthest position reached is greater than current
2190               position, adjust the position and set length to pad out
2191               whats left.  Otherwise just pad whats left.
2192               (for character array unit) */
2193               m = dtp->u.p.current_unit->recl
2194                         - dtp->u.p.current_unit->bytes_left;
2195               if (max_pos > m)
2196                 {
2197                   length = (int) (max_pos - m);
2198                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2199                   length = (int) (dtp->u.p.current_unit->recl - max_pos);
2200                 }
2201
2202               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2203                 {
2204                   generate_error (&dtp->common, ERROR_END, NULL);
2205                   return;
2206                 }
2207
2208               /* Now that the current record has been padded out,
2209                  determine where the next record in the array is. */
2210               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2211               if (record == 0)
2212                 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2213               
2214               /* Now seek to this record */
2215               record = record * dtp->u.p.current_unit->recl;
2216
2217               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2218                 {
2219                   generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2220                   return;
2221                 }
2222
2223               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2224             }
2225           else
2226             {
2227               length = 1;
2228
2229               /* If this is the last call to next_record move to the farthest
2230                  position reached and set length to pad out the remainder
2231                  of the record. (for character scaler unit) */
2232               if (done)
2233                 {
2234                   m = dtp->u.p.current_unit->recl
2235                         - dtp->u.p.current_unit->bytes_left;
2236                   if (max_pos > m)
2237                     {
2238                       length = (int) (max_pos - m);
2239                       p = salloc_w (dtp->u.p.current_unit->s, &length);
2240                       length = (int) (dtp->u.p.current_unit->recl - max_pos);
2241                     }
2242                   else
2243                     length = (int) dtp->u.p.current_unit->bytes_left;
2244                 }
2245               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2246                 {
2247                   generate_error (&dtp->common, ERROR_END, NULL);
2248                   return;
2249                 }
2250             }
2251         }
2252       else
2253         {
2254
2255           /* If this is the last call to next_record move to the farthest
2256           position reached in preparation for completing the record.
2257           (for file unit) */
2258           if (done)
2259             {
2260               m = dtp->u.p.current_unit->recl -
2261                         dtp->u.p.current_unit->bytes_left;
2262               if (max_pos > m)
2263                 {
2264                   length = (int) (max_pos - m);
2265                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2266                 }
2267             }
2268           size_t len;
2269           const char crlf[] = "\r\n";
2270 #ifdef HAVE_CRLF
2271           len = 2;
2272 #else
2273           len = 1;
2274 #endif
2275           if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2276             goto io_error;
2277           
2278           if (is_stream_io (dtp))
2279             dtp->u.p.current_unit->strm_pos += len;
2280         }
2281
2282       break;
2283
2284     io_error:
2285       generate_error (&dtp->common, ERROR_OS, NULL);
2286       break;
2287     }
2288 }
2289
2290 /* Position to the next record, which means moving to the end of the
2291    current record.  This can happen under several different
2292    conditions.  If the done flag is not set, we get ready to process
2293    the next record.  */
2294
2295 void
2296 next_record (st_parameter_dt *dtp, int done)
2297 {
2298   gfc_offset fp; /* File position.  */
2299
2300   dtp->u.p.current_unit->read_bad = 0;
2301
2302   if (dtp->u.p.mode == READING)
2303     next_record_r (dtp);
2304   else
2305     next_record_w (dtp, done);
2306
2307   if (!is_stream_io (dtp))
2308     {
2309       /* keep position up to date for INQUIRE */
2310       dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2311       dtp->u.p.current_unit->current_record = 0;
2312       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2313         {
2314           fp = file_position (dtp->u.p.current_unit->s);
2315           /* Calculate next record, rounding up partial records.  */
2316           dtp->u.p.current_unit->last_record =
2317             (fp + dtp->u.p.current_unit->recl - 1) /
2318               dtp->u.p.current_unit->recl;
2319         }
2320       else
2321         dtp->u.p.current_unit->last_record++;
2322     }
2323
2324   if (!done)
2325     pre_position (dtp);
2326 }
2327
2328
2329 /* Finalize the current data transfer.  For a nonadvancing transfer,
2330    this means advancing to the next record.  For internal units close the
2331    stream associated with the unit.  */
2332
2333 static void
2334 finalize_transfer (st_parameter_dt *dtp)
2335 {
2336   jmp_buf eof_jump;
2337   GFC_INTEGER_4 cf = dtp->common.flags;
2338
2339   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2340     *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
2341
2342   if (dtp->u.p.eor_condition)
2343     {
2344       generate_error (&dtp->common, ERROR_EOR, NULL);
2345       return;
2346     }
2347
2348   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2349     return;
2350
2351   if ((dtp->u.p.ionml != NULL)
2352       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2353     {
2354        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2355          namelist_read (dtp);
2356        else
2357          namelist_write (dtp);
2358     }
2359
2360   dtp->u.p.transfer = NULL;
2361   if (dtp->u.p.current_unit == NULL)
2362     return;
2363
2364   dtp->u.p.eof_jump = &eof_jump;
2365   if (setjmp (eof_jump))
2366     {
2367       generate_error (&dtp->common, ERROR_END, NULL);
2368       return;
2369     }
2370
2371   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2372     finish_list_read (dtp);
2373   else if (!is_stream_io (dtp))
2374     {
2375       dtp->u.p.current_unit->current_record = 0;
2376       if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
2377         {
2378           /* Most systems buffer lines, so force the partial record
2379              to be written out.  */
2380           if (!is_internal_unit (dtp))
2381             flush (dtp->u.p.current_unit->s);
2382           dtp->u.p.seen_dollar = 0;
2383           return;
2384         }
2385       next_record (dtp, 1);
2386     }
2387   else
2388     {
2389       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2390         next_record (dtp, 1);
2391       flush (dtp->u.p.current_unit->s);
2392     }
2393
2394   sfree (dtp->u.p.current_unit->s);
2395 }
2396
2397 /* Transfer function for IOLENGTH. It doesn't actually do any
2398    data transfer, it just updates the length counter.  */
2399
2400 static void
2401 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), 
2402                    void *dest __attribute__ ((unused)),
2403                    int kind __attribute__((unused)), 
2404                    size_t size, size_t nelems)
2405 {
2406   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2407     *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2408 }
2409
2410
2411 /* Initialize the IOLENGTH data transfer. This function is in essence
2412    a very much simplified version of data_transfer_init(), because it
2413    doesn't have to deal with units at all.  */
2414
2415 static void
2416 iolength_transfer_init (st_parameter_dt *dtp)
2417 {
2418   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2419     *dtp->iolength = 0;
2420
2421   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2422
2423   /* Set up the subroutine that will handle the transfers.  */
2424
2425   dtp->u.p.transfer = iolength_transfer;
2426 }
2427
2428
2429 /* Library entry point for the IOLENGTH form of the INQUIRE
2430    statement. The IOLENGTH form requires no I/O to be performed, but
2431    it must still be a runtime library call so that we can determine
2432    the iolength for dynamic arrays and such.  */
2433
2434 extern void st_iolength (st_parameter_dt *);
2435 export_proto(st_iolength);
2436
2437 void
2438 st_iolength (st_parameter_dt *dtp)
2439 {
2440   library_start (&dtp->common);
2441   iolength_transfer_init (dtp);
2442 }
2443
2444 extern void st_iolength_done (st_parameter_dt *);
2445 export_proto(st_iolength_done);
2446
2447 void
2448 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2449 {
2450   free_ionml (dtp);
2451   if (dtp->u.p.scratch != NULL)
2452     free_mem (dtp->u.p.scratch);
2453   library_end ();
2454 }
2455
2456
2457 /* The READ statement.  */
2458
2459 extern void st_read (st_parameter_dt *);
2460 export_proto(st_read);
2461
2462 void
2463 st_read (st_parameter_dt *dtp)
2464 {
2465   library_start (&dtp->common);
2466
2467   data_transfer_init (dtp, 1);
2468
2469   /* Handle complications dealing with the endfile record.  It is
2470      significant that this is the only place where ERROR_END is
2471      generated.  Reading an end of file elsewhere is either end of
2472      record or an I/O error. */
2473
2474   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2475     switch (dtp->u.p.current_unit->endfile)
2476       {
2477       case NO_ENDFILE:
2478         break;
2479
2480       case AT_ENDFILE:
2481         if (!is_internal_unit (dtp))
2482           {
2483             generate_error (&dtp->common, ERROR_END, NULL);
2484             dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2485             dtp->u.p.current_unit->current_record = 0;
2486           }
2487         break;
2488
2489       case AFTER_ENDFILE:
2490         generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2491         dtp->u.p.current_unit->current_record = 0;
2492         break;
2493       }
2494 }
2495
2496 extern void st_read_done (st_parameter_dt *);
2497 export_proto(st_read_done);
2498
2499 void
2500 st_read_done (st_parameter_dt *dtp)
2501 {
2502   finalize_transfer (dtp);
2503   free_format_data (dtp);
2504   free_ionml (dtp);
2505   if (dtp->u.p.scratch != NULL)
2506     free_mem (dtp->u.p.scratch);
2507   if (dtp->u.p.current_unit != NULL)
2508     unlock_unit (dtp->u.p.current_unit);
2509
2510   free_internal_unit (dtp);
2511   
2512   library_end ();
2513 }
2514
2515 extern void st_write (st_parameter_dt *);
2516 export_proto(st_write);
2517
2518 void
2519 st_write (st_parameter_dt *dtp)
2520 {
2521   library_start (&dtp->common);
2522   data_transfer_init (dtp, 0);
2523 }
2524
2525 extern void st_write_done (st_parameter_dt *);
2526 export_proto(st_write_done);
2527
2528 void
2529 st_write_done (st_parameter_dt *dtp)
2530 {
2531   finalize_transfer (dtp);
2532
2533   /* Deal with endfile conditions associated with sequential files.  */
2534
2535   if (dtp->u.p.current_unit != NULL 
2536       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2537     switch (dtp->u.p.current_unit->endfile)
2538       {
2539       case AT_ENDFILE:          /* Remain at the endfile record.  */
2540         break;
2541
2542       case AFTER_ENDFILE:
2543         dtp->u.p.current_unit->endfile = AT_ENDFILE;    /* Just at it now.  */
2544         break;
2545
2546       case NO_ENDFILE:
2547         /* Get rid of whatever is after this record.  */
2548         if (!is_internal_unit (dtp))
2549           {
2550             flush (dtp->u.p.current_unit->s);
2551             if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2552               generate_error (&dtp->common, ERROR_OS, NULL);
2553           }
2554         dtp->u.p.current_unit->endfile = AT_ENDFILE;
2555         break;
2556       }
2557
2558   free_format_data (dtp);
2559   free_ionml (dtp);
2560   if (dtp->u.p.scratch != NULL)
2561     free_mem (dtp->u.p.scratch);
2562   if (dtp->u.p.current_unit != NULL)
2563     unlock_unit (dtp->u.p.current_unit);
2564   
2565   free_internal_unit (dtp);
2566
2567   library_end ();
2568 }
2569
2570 /* Receives the scalar information for namelist objects and stores it
2571    in a linked list of namelist_info types.  */
2572
2573 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2574                             GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2575 export_proto(st_set_nml_var);
2576
2577
2578 void
2579 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2580                 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2581                 GFC_INTEGER_4 dtype)
2582 {
2583   namelist_info *t1 = NULL;
2584   namelist_info *nml;
2585
2586   nml = (namelist_info*) get_mem (sizeof (namelist_info));
2587
2588   nml->mem_pos = var_addr;
2589
2590   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2591   strcpy (nml->var_name, var_name);
2592
2593   nml->len = (int) len;
2594   nml->string_length = (index_type) string_length;
2595
2596   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2597   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2598   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2599
2600   if (nml->var_rank > 0)
2601     {
2602       nml->dim = (descriptor_dimension*)
2603                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
2604       nml->ls = (array_loop_spec*)
2605                   get_mem (nml->var_rank * sizeof (array_loop_spec));
2606     }
2607   else
2608     {
2609       nml->dim = NULL;
2610       nml->ls = NULL;
2611     }
2612
2613   nml->next = NULL;
2614
2615   if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2616     {
2617       dtp->common.flags |= IOPARM_DT_IONML_SET;
2618       dtp->u.p.ionml = nml;
2619     }
2620   else
2621     {
2622       for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2623       t1->next = nml;
2624     }
2625 }
2626
2627 /* Store the dimensional information for the namelist object.  */
2628 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2629                                 GFC_INTEGER_4, GFC_INTEGER_4,
2630                                 GFC_INTEGER_4);
2631 export_proto(st_set_nml_var_dim);
2632
2633 void
2634 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2635                     GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2636                     GFC_INTEGER_4 ubound)
2637 {
2638   namelist_info * nml;
2639   int n;
2640
2641   n = (int)n_dim;
2642
2643   for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2644
2645   nml->dim[n].stride = (ssize_t)stride;
2646   nml->dim[n].lbound = (ssize_t)lbound;
2647   nml->dim[n].ubound = (ssize_t)ubound;
2648 }
2649
2650 /* Reverse memcpy - used for byte swapping.  */
2651
2652 void reverse_memcpy (void *dest, const void *src, size_t n)
2653 {
2654   char *d, *s;
2655   size_t i;
2656
2657   d = (char *) dest;
2658   s = (char *) src + n - 1;
2659
2660   /* Write with ascending order - this is likely faster
2661      on modern architectures because of write combining.  */
2662   for (i=0; i<n; i++)
2663       *(d++) = *(s--);
2664 }