OSDN Git Service

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