OSDN Git Service

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