OSDN Git Service

05711a06015af7d0bb2940fc0a54645b90443e6c
[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       if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1895         {
1896           generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
1897                           "EOR specification requires an ADVANCE specification "
1898                           "of NO");
1899           return;
1900         }
1901
1902       if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1903         {
1904           generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
1905                           "SIZE specification requires an ADVANCE specification of NO");
1906           return;
1907         }
1908     }
1909   else
1910     {                           /* Write constraints.  */
1911       if ((cf & IOPARM_END) != 0)
1912         {
1913           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1914                           "END specification cannot appear in a write statement");
1915           return;
1916         }
1917
1918       if ((cf & IOPARM_EOR) != 0)
1919         {
1920           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1921                           "EOR specification cannot appear in a write statement");
1922           return;
1923         }
1924
1925       if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1926         {
1927           generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1928                           "SIZE specification cannot appear in a write statement");
1929           return;
1930         }
1931     }
1932
1933   if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1934     dtp->u.p.advance_status = ADVANCE_YES;
1935
1936   /* Sanity checks on the record number.  */
1937   if ((cf & IOPARM_DT_HAS_REC) != 0)
1938     {
1939       if (dtp->rec <= 0)
1940         {
1941           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1942                           "Record number must be positive");
1943           return;
1944         }
1945
1946       if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1947         {
1948           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1949                           "Record number too large");
1950           return;
1951         }
1952
1953       /* Check to see if we might be reading what we wrote before  */
1954
1955       if (dtp->u.p.mode == READING
1956           && dtp->u.p.current_unit->mode == WRITING
1957           && !is_internal_unit (dtp))
1958          flush(dtp->u.p.current_unit->s);
1959
1960       /* Check whether the record exists to be read.  Only
1961          a partial record needs to exist.  */
1962
1963       if (dtp->u.p.mode == READING && (dtp->rec -1)
1964           * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1965         {
1966           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1967                           "Non-existing record number");
1968           return;
1969         }
1970
1971       /* Position the file.  */
1972       if (!is_stream_io (dtp))
1973         {
1974           if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1975                      * dtp->u.p.current_unit->recl) == FAILURE)
1976             {
1977               generate_error (&dtp->common, LIBERROR_OS, NULL);
1978               return;
1979             }
1980         }
1981       else
1982         dtp->u.p.current_unit->strm_pos = dtp->rec;
1983
1984     }
1985
1986   /* Overwriting an existing sequential file ?
1987      it is always safe to truncate the file on the first write */
1988   if (dtp->u.p.mode == WRITING
1989       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1990       && dtp->u.p.current_unit->last_record == 0 
1991       && !is_preconnected(dtp->u.p.current_unit->s))
1992         struncate(dtp->u.p.current_unit->s);
1993
1994   /* Bugware for badly written mixed C-Fortran I/O.  */
1995   flush_if_preconnected(dtp->u.p.current_unit->s);
1996
1997   dtp->u.p.current_unit->mode = dtp->u.p.mode;
1998
1999   /* Set the initial value of flags.  */
2000
2001   dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
2002   dtp->u.p.sign_status = SIGN_S;
2003   
2004   /* Set the maximum position reached from the previous I/O operation.  This
2005      could be greater than zero from a previous non-advancing write.  */
2006   dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
2007
2008   pre_position (dtp);
2009
2010   /* Set up the subroutine that will handle the transfers.  */
2011
2012   if (read_flag)
2013     {
2014       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2015         dtp->u.p.transfer = unformatted_read;
2016       else
2017         {
2018           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2019             dtp->u.p.transfer = list_formatted_read;
2020           else
2021             dtp->u.p.transfer = formatted_transfer;
2022         }
2023     }
2024   else
2025     {
2026       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2027         dtp->u.p.transfer = unformatted_write;
2028       else
2029         {
2030           if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2031             dtp->u.p.transfer = list_formatted_write;
2032           else
2033             dtp->u.p.transfer = formatted_transfer;
2034         }
2035     }
2036
2037   /* Make sure that we don't do a read after a nonadvancing write.  */
2038
2039   if (read_flag)
2040     {
2041       if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
2042         {
2043           generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2044                           "Cannot READ after a nonadvancing WRITE");
2045           return;
2046         }
2047     }
2048   else
2049     {
2050       if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2051         dtp->u.p.current_unit->read_bad = 1;
2052     }
2053
2054   /* Start the data transfer if we are doing a formatted transfer.  */
2055   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2056       && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
2057       && dtp->u.p.ionml == NULL)
2058     formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2059 }
2060
2061 /* Initialize an array_loop_spec given the array descriptor.  The function
2062    returns the index of the last element of the array.  */
2063    
2064 gfc_offset
2065 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
2066 {
2067   int rank = GFC_DESCRIPTOR_RANK(desc);
2068   int i;
2069   gfc_offset index; 
2070
2071   index = 1;
2072   for (i=0; i<rank; i++)
2073     {
2074       ls[i].idx = desc->dim[i].lbound;
2075       ls[i].start = desc->dim[i].lbound;
2076       ls[i].end = desc->dim[i].ubound;
2077       ls[i].step = desc->dim[i].stride;
2078       
2079       index += (desc->dim[i].ubound - desc->dim[i].lbound)
2080                       * desc->dim[i].stride;
2081     }
2082   return index;
2083 }
2084
2085 /* Determine the index to the next record in an internal unit array by
2086    by incrementing through the array_loop_spec.  TODO:  Implement handling
2087    negative strides. */
2088    
2089 gfc_offset
2090 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
2091 {
2092   int i, carry;
2093   gfc_offset index;
2094   
2095   carry = 1;
2096   index = 0;
2097   
2098   for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2099     {
2100       if (carry)
2101         {
2102           ls[i].idx++;
2103           if (ls[i].idx > ls[i].end)
2104             {
2105               ls[i].idx = ls[i].start;
2106               carry = 1;
2107             }
2108           else
2109             carry = 0;
2110         }
2111       index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2112     }
2113
2114   return index;
2115 }
2116
2117
2118
2119 /* Skip to the end of the current record, taking care of an optional
2120    record marker of size bytes.  If the file is not seekable, we
2121    read chunks of size MAX_READ until we get to the right
2122    position.  */
2123
2124 #define MAX_READ 4096
2125
2126 static void
2127 skip_record (st_parameter_dt *dtp, size_t bytes)
2128 {
2129   gfc_offset new;
2130   int rlength, length;
2131   char *p;
2132
2133   dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2134   if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2135     return;
2136
2137   if (is_seekable (dtp->u.p.current_unit->s))
2138     {
2139       new = file_position (dtp->u.p.current_unit->s)
2140         + dtp->u.p.current_unit->bytes_left_subrecord;
2141
2142       /* Direct access files do not generate END conditions,
2143          only I/O errors.  */
2144       if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
2145         generate_error (&dtp->common, LIBERROR_OS, NULL);
2146     }
2147   else
2148     {                   /* Seek by reading data.  */
2149       while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2150         {
2151           rlength = length =
2152             (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
2153             MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2154
2155           p = salloc_r (dtp->u.p.current_unit->s, &rlength);
2156           if (p == NULL)
2157             {
2158               generate_error (&dtp->common, LIBERROR_OS, NULL);
2159               return;
2160             }
2161
2162           dtp->u.p.current_unit->bytes_left_subrecord -= length;
2163         }
2164     }
2165
2166 }
2167
2168 #undef MAX_READ
2169
2170 /* Advance to the next record reading unformatted files, taking
2171    care of subrecords.  If complete_record is nonzero, we loop
2172    until all subrecords are cleared.  */
2173
2174 static void
2175 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2176 {
2177   size_t bytes;
2178
2179   bytes =  compile_options.record_marker == 0 ?
2180     sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2181
2182   while(1)
2183     {
2184
2185       /* Skip over tail */
2186
2187       skip_record (dtp, bytes);
2188
2189       if ( ! (complete_record && dtp->u.p.current_unit->continued))
2190         return;
2191
2192       us_read (dtp, 1);
2193     }
2194 }
2195
2196 /* Space to the next record for read mode.  */
2197
2198 static void
2199 next_record_r (st_parameter_dt *dtp)
2200 {
2201   gfc_offset record;
2202   int length, bytes_left;
2203   char *p;
2204
2205   switch (current_mode (dtp))
2206     {
2207     /* No records in unformatted STREAM I/O.  */
2208     case UNFORMATTED_STREAM:
2209       return;
2210     
2211     case UNFORMATTED_SEQUENTIAL:
2212       next_record_r_unf (dtp, 1);
2213       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2214       break;
2215
2216     case FORMATTED_DIRECT:
2217     case UNFORMATTED_DIRECT:
2218       skip_record (dtp, 0);
2219       break;
2220
2221     case FORMATTED_STREAM:
2222     case FORMATTED_SEQUENTIAL:
2223       length = 1;
2224       /* sf_read has already terminated input because of an '\n'  */
2225       if (dtp->u.p.sf_seen_eor)
2226         {
2227           dtp->u.p.sf_seen_eor = 0;
2228           break;
2229         }
2230
2231       if (is_internal_unit (dtp))
2232         {
2233           if (is_array_io (dtp))
2234             {
2235               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2236
2237               /* Now seek to this record.  */
2238               record = record * dtp->u.p.current_unit->recl;
2239               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2240                 {
2241                   generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2242                   break;
2243                 }
2244               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2245             }
2246           else  
2247             {
2248               bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2249               p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2250               if (p != NULL)
2251                 dtp->u.p.current_unit->bytes_left
2252                   = dtp->u.p.current_unit->recl;
2253             } 
2254           break;
2255         }
2256       else do
2257         {
2258           p = salloc_r (dtp->u.p.current_unit->s, &length);
2259
2260           if (p == NULL)
2261             {
2262               generate_error (&dtp->common, LIBERROR_OS, NULL);
2263               break;
2264             }
2265
2266           if (length == 0)
2267             {
2268               dtp->u.p.current_unit->endfile = AT_ENDFILE;
2269               break;
2270             }
2271
2272           if (is_stream_io (dtp))
2273             dtp->u.p.current_unit->strm_pos++;
2274         }
2275       while (*p != '\n');
2276
2277       break;
2278     }
2279
2280   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
2281       && !dtp->u.p.namelist_mode
2282       && dtp->u.p.current_unit->endfile == NO_ENDFILE
2283       && (file_length (dtp->u.p.current_unit->s) ==
2284          file_position (dtp->u.p.current_unit->s)))
2285     dtp->u.p.current_unit->endfile = AT_ENDFILE;
2286
2287 }
2288
2289
2290 /* Small utility function to write a record marker, taking care of
2291    byte swapping and of choosing the correct size.  */
2292
2293 inline static int
2294 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2295 {
2296   size_t len;
2297   GFC_INTEGER_4 buf4;
2298   GFC_INTEGER_8 buf8;
2299   char p[sizeof (GFC_INTEGER_8)];
2300
2301   if (compile_options.record_marker == 0)
2302     len = sizeof (GFC_INTEGER_4);
2303   else
2304     len = compile_options.record_marker;
2305
2306   /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
2307   if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
2308     {
2309       switch (len)
2310         {
2311         case sizeof (GFC_INTEGER_4):
2312           buf4 = buf;
2313           return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2314           break;
2315
2316         case sizeof (GFC_INTEGER_8):
2317           buf8 = buf;
2318           return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2319           break;
2320
2321         default:
2322           runtime_error ("Illegal value for record marker");
2323           break;
2324         }
2325     }
2326   else
2327     {
2328       switch (len)
2329         {
2330         case sizeof (GFC_INTEGER_4):
2331           buf4 = buf;
2332           reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2333           return swrite (dtp->u.p.current_unit->s, p, &len);
2334           break;
2335
2336         case sizeof (GFC_INTEGER_8):
2337           buf8 = buf;
2338           reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
2339           return swrite (dtp->u.p.current_unit->s, p, &len);
2340           break;
2341
2342         default:
2343           runtime_error ("Illegal value for record marker");
2344           break;
2345         }
2346     }
2347
2348 }
2349
2350 /* Position to the next (sub)record in write mode for
2351    unformatted sequential files.  */
2352
2353 static void
2354 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
2355 {
2356   gfc_offset c, m, m_write;
2357   size_t record_marker;
2358
2359   /* Bytes written.  */
2360   m = dtp->u.p.current_unit->recl_subrecord
2361     - dtp->u.p.current_unit->bytes_left_subrecord;
2362   c = file_position (dtp->u.p.current_unit->s);
2363
2364   /* Write the length tail.  If we finish a record containing
2365      subrecords, we write out the negative length.  */
2366
2367   if (dtp->u.p.current_unit->continued)
2368     m_write = -m;
2369   else
2370     m_write = m;
2371
2372   if (write_us_marker (dtp, m_write) != 0)
2373     goto io_error;
2374
2375   if (compile_options.record_marker == 0)
2376     record_marker = sizeof (GFC_INTEGER_4);
2377   else
2378     record_marker = compile_options.record_marker;
2379
2380   /* Seek to the head and overwrite the bogus length with the real
2381      length.  */
2382
2383   if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2384       == FAILURE)
2385     goto io_error;
2386
2387   if (next_subrecord)
2388     m_write = -m;
2389   else
2390     m_write = m;
2391
2392   if (write_us_marker (dtp, m_write) != 0)
2393     goto io_error;
2394
2395   /* Seek past the end of the current record.  */
2396
2397   if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2398     goto io_error;
2399
2400   return;
2401
2402  io_error:
2403   generate_error (&dtp->common, LIBERROR_OS, NULL);
2404   return;
2405
2406 }
2407
2408 /* Position to the next record in write mode.  */
2409
2410 static void
2411 next_record_w (st_parameter_dt *dtp, int done)
2412 {
2413   gfc_offset m, record, max_pos;
2414   int length;
2415   char *p;
2416
2417   /* Zero counters for X- and T-editing.  */
2418   max_pos = dtp->u.p.max_pos;
2419   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2420
2421   switch (current_mode (dtp))
2422     {
2423     /* No records in unformatted STREAM I/O.  */
2424     case UNFORMATTED_STREAM:
2425       return;
2426
2427     case FORMATTED_DIRECT:
2428       if (dtp->u.p.current_unit->bytes_left == 0)
2429         break;
2430
2431       if (sset (dtp->u.p.current_unit->s, ' ', 
2432                 dtp->u.p.current_unit->bytes_left) == FAILURE)
2433         goto io_error;
2434
2435       break;
2436
2437     case UNFORMATTED_DIRECT:
2438       if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2439         goto io_error;
2440       break;
2441
2442     case UNFORMATTED_SEQUENTIAL:
2443       next_record_w_unf (dtp, 0);
2444       dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2445       break;
2446
2447     case FORMATTED_STREAM:
2448     case FORMATTED_SEQUENTIAL:
2449
2450       if (is_internal_unit (dtp))
2451         {
2452           if (is_array_io (dtp))
2453             {
2454               length = (int) dtp->u.p.current_unit->bytes_left;
2455               
2456               /* If the farthest position reached is greater than current
2457               position, adjust the position and set length to pad out
2458               whats left.  Otherwise just pad whats left.
2459               (for character array unit) */
2460               m = dtp->u.p.current_unit->recl
2461                         - dtp->u.p.current_unit->bytes_left;
2462               if (max_pos > m)
2463                 {
2464                   length = (int) (max_pos - m);
2465                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2466                   length = (int) (dtp->u.p.current_unit->recl - max_pos);
2467                 }
2468
2469               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2470                 {
2471                   generate_error (&dtp->common, LIBERROR_END, NULL);
2472                   return;
2473                 }
2474
2475               /* Now that the current record has been padded out,
2476                  determine where the next record in the array is. */
2477               record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2478               if (record == 0)
2479                 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2480               
2481               /* Now seek to this record */
2482               record = record * dtp->u.p.current_unit->recl;
2483
2484               if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2485                 {
2486                   generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2487                   return;
2488                 }
2489
2490               dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2491             }
2492           else
2493             {
2494               length = 1;
2495
2496               /* If this is the last call to next_record move to the farthest
2497                  position reached and set length to pad out the remainder
2498                  of the record. (for character scaler unit) */
2499               if (done)
2500                 {
2501                   m = dtp->u.p.current_unit->recl
2502                         - dtp->u.p.current_unit->bytes_left;
2503                   if (max_pos > m)
2504                     {
2505                       length = (int) (max_pos - m);
2506                       p = salloc_w (dtp->u.p.current_unit->s, &length);
2507                       length = (int) (dtp->u.p.current_unit->recl - max_pos);
2508                     }
2509                   else
2510                     length = (int) dtp->u.p.current_unit->bytes_left;
2511                 }
2512
2513               if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2514                 {
2515                   generate_error (&dtp->common, LIBERROR_END, NULL);
2516                   return;
2517                 }
2518             }
2519         }
2520       else
2521         {
2522           /* If this is the last call to next_record move to the farthest
2523           position reached in preparation for completing the record.
2524           (for file unit) */
2525           if (done)
2526             {
2527               m = dtp->u.p.current_unit->recl -
2528                         dtp->u.p.current_unit->bytes_left;
2529               if (max_pos > m)
2530                 {
2531                   length = (int) (max_pos - m);
2532                   p = salloc_w (dtp->u.p.current_unit->s, &length);
2533                 }
2534             }
2535           size_t len;
2536           const char crlf[] = "\r\n";
2537 #ifdef HAVE_CRLF
2538           len = 2;
2539 #else
2540           len = 1;
2541 #endif
2542           if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2543             goto io_error;
2544           
2545           if (is_stream_io (dtp))
2546             dtp->u.p.current_unit->strm_pos += len;
2547         }
2548
2549       break;
2550
2551     io_error:
2552       generate_error (&dtp->common, LIBERROR_OS, NULL);
2553       break;
2554     }
2555 }
2556
2557 /* Position to the next record, which means moving to the end of the
2558    current record.  This can happen under several different
2559    conditions.  If the done flag is not set, we get ready to process
2560    the next record.  */
2561
2562 void
2563 next_record (st_parameter_dt *dtp, int done)
2564 {
2565   gfc_offset fp; /* File position.  */
2566
2567   dtp->u.p.current_unit->read_bad = 0;
2568
2569   if (dtp->u.p.mode == READING)
2570     next_record_r (dtp);
2571   else
2572     next_record_w (dtp, done);
2573
2574   if (!is_stream_io (dtp))
2575     {
2576       /* Keep position up to date for INQUIRE */
2577       if (done)
2578         update_position (dtp->u.p.current_unit);
2579
2580       dtp->u.p.current_unit->current_record = 0;
2581       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2582         {
2583           fp = file_position (dtp->u.p.current_unit->s);
2584           /* Calculate next record, rounding up partial records.  */
2585           dtp->u.p.current_unit->last_record =
2586             (fp + dtp->u.p.current_unit->recl - 1) /
2587               dtp->u.p.current_unit->recl;
2588         }
2589       else
2590         dtp->u.p.current_unit->last_record++;
2591     }
2592
2593   if (!done)
2594     pre_position (dtp);
2595 }
2596
2597
2598 /* Finalize the current data transfer.  For a nonadvancing transfer,
2599    this means advancing to the next record.  For internal units close the
2600    stream associated with the unit.  */
2601
2602 static void
2603 finalize_transfer (st_parameter_dt *dtp)
2604 {
2605   jmp_buf eof_jump;
2606   GFC_INTEGER_4 cf = dtp->common.flags;
2607
2608   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2609     *dtp->size = (GFC_IO_INT) dtp->u.p.size_used;
2610
2611   if (dtp->u.p.eor_condition)
2612     {
2613       generate_error (&dtp->common, LIBERROR_EOR, NULL);
2614       return;
2615     }
2616
2617   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2618     return;
2619
2620   if ((dtp->u.p.ionml != NULL)
2621       && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2622     {
2623        if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2624          namelist_read (dtp);
2625        else
2626          namelist_write (dtp);
2627     }
2628
2629   dtp->u.p.transfer = NULL;
2630   if (dtp->u.p.current_unit == NULL)
2631     return;
2632
2633   dtp->u.p.eof_jump = &eof_jump;
2634   if (setjmp (eof_jump))
2635     {
2636       generate_error (&dtp->common, LIBERROR_END, NULL);
2637       return;
2638     }
2639
2640   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2641     {
2642       finish_list_read (dtp);
2643       sfree (dtp->u.p.current_unit->s);
2644       return;
2645     }
2646
2647   if (is_stream_io (dtp))
2648     {
2649       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2650         next_record (dtp, 1);
2651
2652       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
2653           && file_position (dtp->u.p.current_unit->s) >= dtp->rec)
2654         {
2655           flush (dtp->u.p.current_unit->s);
2656           sfree (dtp->u.p.current_unit->s);
2657         }
2658       return;
2659     }
2660
2661   dtp->u.p.current_unit->current_record = 0;
2662
2663   if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2664     {
2665       dtp->u.p.seen_dollar = 0;
2666       sfree (dtp->u.p.current_unit->s);
2667       return;
2668     }
2669
2670   /* For non-advancing I/O, save the current maximum position for use in the
2671      next I/O operation if needed.  */
2672   if (dtp->u.p.advance_status == ADVANCE_NO)
2673     {
2674       int bytes_written = (int) (dtp->u.p.current_unit->recl
2675         - dtp->u.p.current_unit->bytes_left);
2676       dtp->u.p.current_unit->saved_pos =
2677         dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
2678       flush (dtp->u.p.current_unit->s);
2679       return;
2680     }
2681
2682   dtp->u.p.current_unit->saved_pos = 0;
2683
2684   next_record (dtp, 1);
2685   sfree (dtp->u.p.current_unit->s);
2686 }
2687
2688 /* Transfer function for IOLENGTH. It doesn't actually do any
2689    data transfer, it just updates the length counter.  */
2690
2691 static void
2692 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), 
2693                    void *dest __attribute__ ((unused)),
2694                    int kind __attribute__((unused)), 
2695                    size_t size, size_t nelems)
2696 {
2697   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2698     *dtp->iolength += (GFC_IO_INT) size * nelems;
2699 }
2700
2701
2702 /* Initialize the IOLENGTH data transfer. This function is in essence
2703    a very much simplified version of data_transfer_init(), because it
2704    doesn't have to deal with units at all.  */
2705
2706 static void
2707 iolength_transfer_init (st_parameter_dt *dtp)
2708 {
2709   if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2710     *dtp->iolength = 0;
2711
2712   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2713
2714   /* Set up the subroutine that will handle the transfers.  */
2715
2716   dtp->u.p.transfer = iolength_transfer;
2717 }
2718
2719
2720 /* Library entry point for the IOLENGTH form of the INQUIRE
2721    statement. The IOLENGTH form requires no I/O to be performed, but
2722    it must still be a runtime library call so that we can determine
2723    the iolength for dynamic arrays and such.  */
2724
2725 extern void st_iolength (st_parameter_dt *);
2726 export_proto(st_iolength);
2727
2728 void
2729 st_iolength (st_parameter_dt *dtp)
2730 {
2731   library_start (&dtp->common);
2732   iolength_transfer_init (dtp);
2733 }
2734
2735 extern void st_iolength_done (st_parameter_dt *);
2736 export_proto(st_iolength_done);
2737
2738 void
2739 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2740 {
2741   free_ionml (dtp);
2742   if (dtp->u.p.scratch != NULL)
2743     free_mem (dtp->u.p.scratch);
2744   library_end ();
2745 }
2746
2747
2748 /* The READ statement.  */
2749
2750 extern void st_read (st_parameter_dt *);
2751 export_proto(st_read);
2752
2753 void
2754 st_read (st_parameter_dt *dtp)
2755 {
2756   library_start (&dtp->common);
2757
2758   data_transfer_init (dtp, 1);
2759
2760   /* Handle complications dealing with the endfile record.  */
2761
2762   if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2763     switch (dtp->u.p.current_unit->endfile)
2764       {
2765       case NO_ENDFILE:
2766         break;
2767
2768       case AT_ENDFILE:
2769         if (!is_internal_unit (dtp))
2770           {
2771             generate_error (&dtp->common, LIBERROR_END, NULL);
2772             dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2773             dtp->u.p.current_unit->current_record = 0;
2774           }
2775         break;
2776
2777       case AFTER_ENDFILE:
2778         generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
2779         dtp->u.p.current_unit->current_record = 0;
2780         break;
2781       }
2782 }
2783
2784 extern void st_read_done (st_parameter_dt *);
2785 export_proto(st_read_done);
2786
2787 void
2788 st_read_done (st_parameter_dt *dtp)
2789 {
2790   finalize_transfer (dtp);
2791   free_format_data (dtp);
2792   free_ionml (dtp);
2793   if (dtp->u.p.scratch != NULL)
2794     free_mem (dtp->u.p.scratch);
2795   if (dtp->u.p.current_unit != NULL)
2796     unlock_unit (dtp->u.p.current_unit);
2797
2798   free_internal_unit (dtp);
2799   
2800   library_end ();
2801 }
2802
2803 extern void st_write (st_parameter_dt *);
2804 export_proto(st_write);
2805
2806 void
2807 st_write (st_parameter_dt *dtp)
2808 {
2809   library_start (&dtp->common);
2810   data_transfer_init (dtp, 0);
2811 }
2812
2813 extern void st_write_done (st_parameter_dt *);
2814 export_proto(st_write_done);
2815
2816 void
2817 st_write_done (st_parameter_dt *dtp)
2818 {
2819   finalize_transfer (dtp);
2820
2821   /* Deal with endfile conditions associated with sequential files.  */
2822
2823   if (dtp->u.p.current_unit != NULL 
2824       && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2825     switch (dtp->u.p.current_unit->endfile)
2826       {
2827       case AT_ENDFILE:          /* Remain at the endfile record.  */
2828         break;
2829
2830       case AFTER_ENDFILE:
2831         dtp->u.p.current_unit->endfile = AT_ENDFILE;    /* Just at it now.  */
2832         break;
2833
2834       case NO_ENDFILE:
2835         /* Get rid of whatever is after this record.  */
2836         if (!is_internal_unit (dtp))
2837           {
2838             flush (dtp->u.p.current_unit->s);
2839             if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2840               generate_error (&dtp->common, LIBERROR_OS, NULL);
2841           }
2842         dtp->u.p.current_unit->endfile = AT_ENDFILE;
2843         break;
2844       }
2845
2846   free_format_data (dtp);
2847   free_ionml (dtp);
2848   if (dtp->u.p.scratch != NULL)
2849     free_mem (dtp->u.p.scratch);
2850   if (dtp->u.p.current_unit != NULL)
2851     unlock_unit (dtp->u.p.current_unit);
2852   
2853   free_internal_unit (dtp);
2854
2855   library_end ();
2856 }
2857
2858 /* Receives the scalar information for namelist objects and stores it
2859    in a linked list of namelist_info types.  */
2860
2861 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2862                             GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2863 export_proto(st_set_nml_var);
2864
2865
2866 void
2867 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2868                 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2869                 GFC_INTEGER_4 dtype)
2870 {
2871   namelist_info *t1 = NULL;
2872   namelist_info *nml;
2873   size_t var_name_len = strlen (var_name);
2874
2875   nml = (namelist_info*) get_mem (sizeof (namelist_info));
2876
2877   nml->mem_pos = var_addr;
2878
2879   nml->var_name = (char*) get_mem (var_name_len + 1);
2880   memcpy (nml->var_name, var_name, var_name_len);
2881   nml->var_name[var_name_len] = '\0';
2882
2883   nml->len = (int) len;
2884   nml->string_length = (index_type) string_length;
2885
2886   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2887   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2888   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2889
2890   if (nml->var_rank > 0)
2891     {
2892       nml->dim = (descriptor_dimension*)
2893                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
2894       nml->ls = (array_loop_spec*)
2895                   get_mem (nml->var_rank * sizeof (array_loop_spec));
2896     }
2897   else
2898     {
2899       nml->dim = NULL;
2900       nml->ls = NULL;
2901     }
2902
2903   nml->next = NULL;
2904
2905   if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2906     {
2907       dtp->common.flags |= IOPARM_DT_IONML_SET;
2908       dtp->u.p.ionml = nml;
2909     }
2910   else
2911     {
2912       for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2913       t1->next = nml;
2914     }
2915 }
2916
2917 /* Store the dimensional information for the namelist object.  */
2918 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2919                                 index_type, index_type,
2920                                 index_type);
2921 export_proto(st_set_nml_var_dim);
2922
2923 void
2924 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2925                     index_type stride, index_type lbound,
2926                     index_type ubound)
2927 {
2928   namelist_info * nml;
2929   int n;
2930
2931   n = (int)n_dim;
2932
2933   for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2934
2935   nml->dim[n].stride = stride;
2936   nml->dim[n].lbound = lbound;
2937   nml->dim[n].ubound = ubound;
2938 }
2939
2940 /* Reverse memcpy - used for byte swapping.  */
2941
2942 void reverse_memcpy (void *dest, const void *src, size_t n)
2943 {
2944   char *d, *s;
2945   size_t i;
2946
2947   d = (char *) dest;
2948   s = (char *) src + n - 1;
2949
2950   /* Write with ascending order - this is likely faster
2951      on modern architectures because of write combining.  */
2952   for (i=0; i<n; i++)
2953       *(d++) = *(s--);
2954 }