OSDN Git Service

ca9246b89f7c1394173e457cb003a1f446290b9d
[pf3gnuchains/gcc-fork.git] / libgfortran / io / transfer.c
1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3    Namelist transfer functions contributed by Paul Thomas
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file.  (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
20
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24 GNU General Public License for more details.
25
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING.  If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA.  */
30
31
32 /* transfer.c -- Top level handling of data transfer statements.  */
33
34 #include "config.h"
35 #include <string.h>
36 #include <assert.h>
37 #include "libgfortran.h"
38 #include "io.h"
39
40
41 /* Calling conventions:  Data transfer statements are unlike other
42    library calls in that they extend over several calls.
43
44    The first call is always a call to st_read() or st_write().  These
45    subroutines return no status unless a namelist read or write is
46    being done, in which case there is the usual status.  No further
47    calls are necessary in this case.
48
49    For other sorts of data transfer, there are zero or more data
50    transfer statement that depend on the format of the data transfer
51    statement.
52
53       transfer_integer
54       transfer_logical
55       transfer_character
56       transfer_real
57       transfer_complex
58
59     These subroutines do not return status.
60
61     The last call is a call to st_[read|write]_done().  While
62     something can easily go wrong with the initial st_read() or
63     st_write(), an error inhibits any data from actually being
64     transferred.  */
65
66 extern void transfer_integer (void *, int);
67 export_proto(transfer_integer);
68
69 extern void transfer_real (void *, int);
70 export_proto(transfer_real);
71
72 extern void transfer_logical (void *, int);
73 export_proto(transfer_logical);
74
75 extern void transfer_character (void *, int);
76 export_proto(transfer_character);
77
78 extern void transfer_complex (void *, int);
79 export_proto(transfer_complex);
80
81 extern void transfer_array (gfc_array_char *, gfc_charlen_type);
82 export_proto(transfer_array);
83
84 gfc_unit *current_unit = NULL;
85 static int sf_seen_eor = 0;
86 static int eor_condition = 0;
87
88 /* Maximum righthand column written to.  */
89 static int max_pos;
90 /* Number of skips + spaces to be done for T and X-editing.  */
91 static int skips;
92 /* Number of spaces to be done for T and X-editing.  */
93 static int pending_spaces;
94
95 char scratch[SCRATCH_SIZE];
96 static char *line_buffer = NULL;
97
98 static unit_advance advance_status;
99
100 static st_option advance_opt[] = {
101   {"yes", ADVANCE_YES},
102   {"no", ADVANCE_NO},
103   {NULL, 0}
104 };
105
106
107 static void (*transfer) (bt, void *, int, size_t);
108
109
110 typedef enum
111 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
112   FORMATTED_DIRECT, UNFORMATTED_DIRECT
113 }
114 file_mode;
115
116
117 static file_mode
118 current_mode (void)
119 {
120   file_mode m;
121
122   if (current_unit->flags.access == ACCESS_DIRECT)
123     {
124       m = current_unit->flags.form == FORM_FORMATTED ?
125         FORMATTED_DIRECT : UNFORMATTED_DIRECT;
126     }
127   else
128     {
129       m = current_unit->flags.form == FORM_FORMATTED ?
130         FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
131     }
132
133   return m;
134 }
135
136
137 /* Mid level data transfer statements.  These subroutines do reading
138    and writing in the style of salloc_r()/salloc_w() within the
139    current record.  */
140
141 /* When reading sequential formatted records we have a problem.  We
142    don't know how long the line is until we read the trailing newline,
143    and we don't want to read too much.  If we read too much, we might
144    have to do a physical seek backwards depending on how much data is
145    present, and devices like terminals aren't seekable and would cause
146    an I/O error.
147
148    Given this, the solution is to read a byte at a time, stopping if
149    we hit the newline.  For small locations, we use a static buffer.
150    For larger allocations, we are forced to allocate memory on the
151    heap.  Hopefully this won't happen very often.  */
152
153 static char *
154 read_sf (int *length)
155 {
156   static char data[SCRATCH_SIZE];
157   char *base, *p, *q;
158   int n, readlen;
159
160   if (*length > SCRATCH_SIZE)
161     p = base = line_buffer = get_mem (*length);
162   else
163     p = base = data;
164
165   /* If we have seen an eor previously, return a length of 0.  The
166      caller is responsible for correctly padding the input field.  */
167   if (sf_seen_eor)
168     {
169       *length = 0;
170       return base;
171     }
172
173   readlen = 1;
174   n = 0;
175
176   do
177     {
178       if (is_internal_unit())
179         {
180           /* readlen may be modified inside salloc_r if
181              is_internal_unit() is true.  */
182           readlen = 1;
183         }
184
185       q = salloc_r (current_unit->s, &readlen);
186       if (q == NULL)
187         break;
188
189       /* If we have a line without a terminating \n, drop through to
190          EOR below.  */
191       if (readlen < 1 && n == 0)
192         {
193           generate_error (ERROR_END, NULL);
194           return NULL;
195         }
196
197       if (readlen < 1 || *q == '\n' || *q == '\r')
198         {
199           /* Unexpected end of line.  */
200
201           /* If we see an EOR during non-advancing I/O, we need to skip
202              the rest of the I/O statement.  Set the corresponding flag.  */
203           if (advance_status == ADVANCE_NO || g.seen_dollar)
204             eor_condition = 1;
205
206           /* Without padding, terminate the I/O statement without assigning
207              the value.  With padding, the value still needs to be assigned,
208              so we can just continue with a short read.  */
209           if (current_unit->flags.pad == PAD_NO)
210             {
211               generate_error (ERROR_EOR, NULL);
212               return NULL;
213             }
214
215           current_unit->bytes_left = 0;
216           *length = n;
217           sf_seen_eor = 1;
218           break;
219         }
220
221       n++;
222       *p++ = *q;
223       sf_seen_eor = 0;
224     }
225   while (n < *length);
226   current_unit->bytes_left -= *length;
227
228   if (ioparm.size != NULL)
229     *ioparm.size += *length;
230
231   return base;
232 }
233
234
235 /* Function for reading the next couple of bytes from the current
236    file, advancing the current position.  We return a pointer to a
237    buffer containing the bytes.  We return NULL on end of record or
238    end of file.
239
240    If the read is short, then it is because the current record does not
241    have enough data to satisfy the read request and the file was
242    opened with PAD=YES.  The caller must assume tailing spaces for
243    short reads.  */
244
245 void *
246 read_block (int *length)
247 {
248   char *source;
249   int nread;
250
251   if (current_unit->flags.form == FORM_FORMATTED &&
252       current_unit->flags.access == ACCESS_SEQUENTIAL)
253     return read_sf (length);    /* Special case.  */
254
255   if (current_unit->bytes_left < *length)
256     {
257       if (current_unit->flags.pad == PAD_NO)
258         {
259           generate_error (ERROR_EOR, NULL); /* Not enough data left.  */
260           return NULL;
261         }
262
263       *length = current_unit->bytes_left;
264     }
265
266   current_unit->bytes_left -= *length;
267
268   nread = *length;
269   source = salloc_r (current_unit->s, &nread);
270
271   if (ioparm.size != NULL)
272     *ioparm.size += nread;
273
274   if (nread != *length)
275     {                           /* Short read, this shouldn't happen.  */
276       if (current_unit->flags.pad == PAD_YES)
277         *length = nread;
278       else
279         {
280           generate_error (ERROR_EOR, NULL);
281           source = NULL;
282         }
283     }
284
285   return source;
286 }
287
288
289 /* Function for writing a block of bytes to the current file at the
290    current position, advancing the file pointer. We are given a length
291    and return a pointer to a buffer that the caller must (completely)
292    fill in.  Returns NULL on error.  */
293
294 void *
295 write_block (int length)
296 {
297   char *dest;
298   
299   if (current_unit->bytes_left < length)
300     {
301       generate_error (ERROR_EOR, NULL);
302       return NULL;
303     }
304
305   current_unit->bytes_left -= (gfc_offset)length;
306   dest = salloc_w (current_unit->s, &length);
307
308   if (ioparm.size != NULL)
309     *ioparm.size += length;
310
311   return dest;
312 }
313
314
315 /* Master function for unformatted reads.  */
316
317 static void
318 unformatted_read (bt type, void *dest, int length, size_t nelems)
319 {
320   void *source;
321   int w;
322
323   length *= nelems;
324
325   /* Transfer functions get passed the kind of the entity, so we have
326      to fix this for COMPLEX data which are twice the size of their
327      kind.  */
328   if (type == BT_COMPLEX)
329     length *= 2;
330
331   w = length;
332   source = read_block (&w);
333
334   if (source != NULL)
335     {
336       memcpy (dest, source, w);
337       if (length != w)
338         memset (((char *) dest) + w, ' ', length - w);
339     }
340 }
341
342 /* Master function for unformatted writes.  */
343
344 static void
345 unformatted_write (bt type, void *source, int length, size_t nelems)
346 {
347   void *dest;
348   size_t len;
349
350   len = length * nelems;
351
352   /* Correction for kind vs. length as in unformatted_read.  */
353   if (type == BT_COMPLEX)
354     len *= 2;
355
356   dest = write_block (len);
357   if (dest != NULL)
358     memcpy (dest, source, len);
359 }
360
361
362 /* Return a pointer to the name of a type.  */
363
364 const char *
365 type_name (bt type)
366 {
367   const char *p;
368
369   switch (type)
370     {
371     case BT_INTEGER:
372       p = "INTEGER";
373       break;
374     case BT_LOGICAL:
375       p = "LOGICAL";
376       break;
377     case BT_CHARACTER:
378       p = "CHARACTER";
379       break;
380     case BT_REAL:
381       p = "REAL";
382       break;
383     case BT_COMPLEX:
384       p = "COMPLEX";
385       break;
386     default:
387       internal_error ("type_name(): Bad type");
388     }
389
390   return p;
391 }
392
393
394 /* Write a constant string to the output.
395    This is complicated because the string can have doubled delimiters
396    in it.  The length in the format node is the true length.  */
397
398 static void
399 write_constant_string (fnode * f)
400 {
401   char c, delimiter, *p, *q;
402   int length;
403
404   length = f->u.string.length;
405   if (length == 0)
406     return;
407
408   p = write_block (length);
409   if (p == NULL)
410     return;
411
412   q = f->u.string.p;
413   delimiter = q[-1];
414
415   for (; length > 0; length--)
416     {
417       c = *p++ = *q++;
418       if (c == delimiter && c != 'H' && c != 'h')
419         q++;                    /* Skip the doubled delimiter.  */
420     }
421 }
422
423
424 /* Given actual and expected types in a formatted data transfer, make
425    sure they agree.  If not, an error message is generated.  Returns
426    nonzero if something went wrong.  */
427
428 static int
429 require_type (bt expected, bt actual, fnode * f)
430 {
431   char buffer[100];
432
433   if (actual == expected)
434     return 0;
435
436   st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
437               type_name (expected), g.item_count, type_name (actual));
438
439   format_error (f, buffer);
440   return 1;
441 }
442
443
444 /* This subroutine is the main loop for a formatted data transfer
445    statement.  It would be natural to implement this as a coroutine
446    with the user program, but C makes that awkward.  We loop,
447    processesing format elements.  When we actually have to transfer
448    data instead of just setting flags, we return control to the user
449    program which calls a subroutine that supplies the address and type
450    of the next element, then comes back here to process it.  */
451
452 static void
453 formatted_transfer_scalar (bt type, void *p, int len)
454 {
455   int pos, bytes_used;
456   fnode *f;
457   format_token t;
458   int n;
459   int consume_data_flag;
460
461   /* Change a complex data item into a pair of reals.  */
462
463   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
464   if (type == BT_COMPLEX)
465     type = BT_REAL;
466
467   /* If there's an EOR condition, we simulate finalizing the transfer
468      by doing nothing.  */
469   if (eor_condition)
470     return;
471
472   for (;;)
473     {
474       /* If reversion has occurred and there is another real data item,
475          then we have to move to the next record.  */
476       if (g.reversion_flag && n > 0)
477         {
478           g.reversion_flag = 0;
479           next_record (0);
480         }
481
482       consume_data_flag = 1 ;
483       if (ioparm.library_return != LIBRARY_OK)
484         break;
485
486       f = next_format ();
487       if (f == NULL)
488         return;       /* No data descriptors left (already raised).  */
489
490       /* Now discharge T, TR and X movements to the right.  This is delayed
491          until a data producing format to suppress trailing spaces.  */
492       t = f->format;
493       if (g.mode == WRITING && skips != 0
494         && ((n>0 && (  t == FMT_I  || t == FMT_B  || t == FMT_O
495                     || t == FMT_Z  || t == FMT_F  || t == FMT_E
496                     || t == FMT_EN || t == FMT_ES || t == FMT_G
497                     || t == FMT_L  || t == FMT_A  || t == FMT_D))
498             || t == FMT_STRING))
499         {
500           if (skips > 0)
501             {
502               write_x (skips, pending_spaces);
503               max_pos = (int)(current_unit->recl - current_unit->bytes_left);
504             }
505           if (skips < 0)
506             {
507               move_pos_offset (current_unit->s, skips);
508               current_unit->bytes_left -= (gfc_offset)skips;
509             }
510           skips = pending_spaces = 0;
511         }
512
513       bytes_used = (int)(current_unit->recl - current_unit->bytes_left);
514
515       switch (t)
516         {
517         case FMT_I:
518           if (n == 0)
519             goto need_data;
520           if (require_type (BT_INTEGER, type, f))
521             return;
522
523           if (g.mode == READING)
524             read_decimal (f, p, len);
525           else
526             write_i (f, p, len);
527
528           break;
529
530         case FMT_B:
531           if (n == 0)
532             goto need_data;
533           if (require_type (BT_INTEGER, type, f))
534             return;
535
536           if (g.mode == READING)
537             read_radix (f, p, len, 2);
538           else
539             write_b (f, p, len);
540
541           break;
542
543         case FMT_O:
544           if (n == 0)
545             goto need_data;
546
547           if (g.mode == READING)
548             read_radix (f, p, len, 8);
549           else
550             write_o (f, p, len);
551
552           break;
553
554         case FMT_Z:
555           if (n == 0)
556             goto need_data;
557
558           if (g.mode == READING)
559             read_radix (f, p, len, 16);
560           else
561             write_z (f, p, len);
562
563           break;
564
565         case FMT_A:
566           if (n == 0)
567             goto need_data;
568
569           if (g.mode == READING)
570             read_a (f, p, len);
571           else
572             write_a (f, p, len);
573
574           break;
575
576         case FMT_L:
577           if (n == 0)
578             goto need_data;
579
580           if (g.mode == READING)
581             read_l (f, p, len);
582           else
583             write_l (f, p, len);
584
585           break;
586
587         case FMT_D:
588           if (n == 0)
589             goto need_data;
590           if (require_type (BT_REAL, type, f))
591             return;
592
593           if (g.mode == READING)
594             read_f (f, p, len);
595           else
596             write_d (f, p, len);
597
598           break;
599
600         case FMT_E:
601           if (n == 0)
602             goto need_data;
603           if (require_type (BT_REAL, type, f))
604             return;
605
606           if (g.mode == READING)
607             read_f (f, p, len);
608           else
609             write_e (f, p, len);
610           break;
611
612         case FMT_EN:
613           if (n == 0)
614             goto need_data;
615           if (require_type (BT_REAL, type, f))
616             return;
617
618           if (g.mode == READING)
619             read_f (f, p, len);
620           else
621             write_en (f, p, len);
622
623           break;
624
625         case FMT_ES:
626           if (n == 0)
627             goto need_data;
628           if (require_type (BT_REAL, type, f))
629             return;
630
631           if (g.mode == READING)
632             read_f (f, p, len);
633           else
634             write_es (f, p, len);
635
636           break;
637
638         case FMT_F:
639           if (n == 0)
640             goto need_data;
641           if (require_type (BT_REAL, type, f))
642             return;
643
644           if (g.mode == READING)
645             read_f (f, p, len);
646           else
647             write_f (f, p, len);
648
649           break;
650
651         case FMT_G:
652           if (n == 0)
653             goto need_data;
654           if (g.mode == READING)
655             switch (type)
656               {
657               case BT_INTEGER:
658                 read_decimal (f, p, len);
659                 break;
660               case BT_LOGICAL:
661                 read_l (f, p, len);
662                 break;
663               case BT_CHARACTER:
664                 read_a (f, p, len);
665                 break;
666               case BT_REAL:
667                 read_f (f, p, len);
668                 break;
669               default:
670                 goto bad_type;
671               }
672           else
673             switch (type)
674               {
675               case BT_INTEGER:
676                 write_i (f, p, len);
677                 break;
678               case BT_LOGICAL:
679                 write_l (f, p, len);
680                 break;
681               case BT_CHARACTER:
682                 write_a (f, p, len);
683                 break;
684               case BT_REAL:
685                 write_d (f, p, len);
686                 break;
687               default:
688               bad_type:
689                 internal_error ("formatted_transfer(): Bad type");
690               }
691
692           break;
693
694         case FMT_STRING:
695           consume_data_flag = 0 ;
696           if (g.mode == READING)
697             {
698               format_error (f, "Constant string in input format");
699               return;
700             }
701           write_constant_string (f);
702           break;
703
704         /* Format codes that don't transfer data.  */
705         case FMT_X:
706         case FMT_TR:
707           consume_data_flag = 0 ;
708
709           pos = bytes_used + f->u.n + skips;
710           skips = f->u.n + skips;
711           pending_spaces = pos - max_pos;
712
713           /* Writes occur just before the switch on f->format, above, so that
714              trailing blanks are suppressed.  */
715           if (g.mode == READING)
716             read_x (f->u.n);
717
718           break;
719
720         case FMT_TL:
721         case FMT_T:
722           if (f->format == FMT_TL)
723             pos = bytes_used - f->u.n;
724           else /* FMT_T */
725             {
726               consume_data_flag = 0;
727               pos = f->u.n - 1;
728             }
729
730           /* Standard 10.6.1.1: excessive left tabbing is reset to the
731              left tab limit.  We do not check if the position has gone
732              beyond the end of record because a subsequent tab could
733              bring us back again.  */
734           pos = pos < 0 ? 0 : pos;
735
736           skips = skips + pos - bytes_used;
737           pending_spaces =  pending_spaces + pos - max_pos;
738
739           if (skips == 0)
740             break;
741
742           /* Writes occur just before the switch on f->format, above, so that
743              trailing blanks are suppressed.  */
744           if (g.mode == READING)
745             {
746               if (skips > 0)
747                 read_x (skips);
748               if (skips < 0)
749                 {
750                   move_pos_offset (current_unit->s, skips);
751                   current_unit->bytes_left -= (gfc_offset)skips;
752                   skips = pending_spaces = 0;
753                 }
754             }
755
756           break;
757
758         case FMT_S:
759           consume_data_flag = 0 ;
760           g.sign_status = SIGN_S;
761           break;
762
763         case FMT_SS:
764           consume_data_flag = 0 ;
765           g.sign_status = SIGN_SS;
766           break;
767
768         case FMT_SP:
769           consume_data_flag = 0 ;
770           g.sign_status = SIGN_SP;
771           break;
772
773         case FMT_BN:
774           consume_data_flag = 0 ;
775           g.blank_status = BLANK_NULL;
776           break;
777
778         case FMT_BZ:
779           consume_data_flag = 0 ;
780           g.blank_status = BLANK_ZERO;
781           break;
782
783         case FMT_P:
784           consume_data_flag = 0 ;
785           g.scale_factor = f->u.k;
786           break;
787
788         case FMT_DOLLAR:
789           consume_data_flag = 0 ;
790           g.seen_dollar = 1;
791           break;
792
793         case FMT_SLASH:
794           consume_data_flag = 0 ;
795           skips = pending_spaces = 0;
796           next_record (0);
797           break;
798
799         case FMT_COLON:
800           /* A colon descriptor causes us to exit this loop (in
801              particular preventing another / descriptor from being
802              processed) unless there is another data item to be
803              transferred.  */
804           consume_data_flag = 0 ;
805           if (n == 0)
806             return;
807           break;
808
809         default:
810           internal_error ("Bad format node");
811         }
812
813       /* Free a buffer that we had to allocate during a sequential
814          formatted read of a block that was larger than the static
815          buffer.  */
816
817       if (line_buffer != NULL)
818         {
819           free_mem (line_buffer);
820           line_buffer = NULL;
821         }
822
823       /* Adjust the item count and data pointer.  */
824
825       if ((consume_data_flag > 0) && (n > 0))
826       {
827         n--;
828         p = ((char *) p) + len;
829       }
830
831       if (g.mode == READING)
832         skips = 0;
833
834       pos = (int)(current_unit->recl - current_unit->bytes_left);
835       max_pos = (max_pos > pos) ? max_pos : pos;
836
837     }
838
839   return;
840
841   /* Come here when we need a data descriptor but don't have one.  We
842      push the current format node back onto the input, then return and
843      let the user program call us back with the data.  */
844  need_data:
845   unget_format (f);
846 }
847
848 static void
849 formatted_transfer (bt type, void *p, int len, size_t nelems)
850 {
851   size_t elem;
852   int  size;
853   char *tmp;
854
855   tmp = (char *) p;
856
857   if (type == BT_COMPLEX)
858     size = 2 * len;
859   else
860     size = len;
861
862   /* Big loop over all the elements.  */
863   for (elem = 0; elem < nelems; elem++)
864     {
865       g.item_count++;
866       formatted_transfer_scalar (type, tmp + size*elem, len);
867     }
868 }
869
870
871
872 /* Data transfer entry points.  The type of the data entity is
873    implicit in the subroutine call.  This prevents us from having to
874    share a common enum with the compiler.  */
875
876 void
877 transfer_integer (void *p, int kind)
878 {
879   if (ioparm.library_return != LIBRARY_OK)
880     return;
881   transfer (BT_INTEGER, p, kind, 1);
882 }
883
884
885 void
886 transfer_real (void *p, int kind)
887 {
888   if (ioparm.library_return != LIBRARY_OK)
889     return;
890   transfer (BT_REAL, p, kind, 1);
891 }
892
893
894 void
895 transfer_logical (void *p, int kind)
896 {
897   if (ioparm.library_return != LIBRARY_OK)
898     return;
899   transfer (BT_LOGICAL, p, kind, 1);
900 }
901
902
903 void
904 transfer_character (void *p, int len)
905 {
906   if (ioparm.library_return != LIBRARY_OK)
907     return;
908   transfer (BT_CHARACTER, p, len, 1);
909 }
910
911
912 void
913 transfer_complex (void *p, int kind)
914 {
915   if (ioparm.library_return != LIBRARY_OK)
916     return;
917   transfer (BT_COMPLEX, p, kind, 1);
918 }
919
920
921 void
922 transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
923 {
924   index_type count[GFC_MAX_DIMENSIONS];
925   index_type extent[GFC_MAX_DIMENSIONS];
926   index_type stride[GFC_MAX_DIMENSIONS];
927   index_type stride0, rank, size, type, n, kind;
928   size_t tsize;
929   char *data;
930   bt iotype;
931
932   if (ioparm.library_return != LIBRARY_OK)
933     return;
934
935   type = GFC_DESCRIPTOR_TYPE (desc);
936   size = GFC_DESCRIPTOR_SIZE (desc);
937   kind = size;
938
939   /* FIXME: What a kludge: Array descriptors and the IO library use
940      different enums for types.  */
941   switch (type)
942     {
943     case GFC_DTYPE_UNKNOWN:
944       iotype = BT_NULL;  /* Is this correct?  */
945       break;
946     case GFC_DTYPE_INTEGER:
947       iotype = BT_INTEGER;
948       break;
949     case GFC_DTYPE_LOGICAL:
950       iotype = BT_LOGICAL;
951       break;
952     case GFC_DTYPE_REAL:
953       iotype = BT_REAL;
954       break;
955     case GFC_DTYPE_COMPLEX:
956       iotype = BT_COMPLEX;
957       kind /= 2;
958       break;
959     case GFC_DTYPE_CHARACTER:
960       iotype = BT_CHARACTER;
961       /* FIXME: Currently dtype contains the charlen, which is
962          clobbered if charlen > 2**24. That's why we use a separate
963          argument for the charlen. However, if we want to support
964          non-8-bit charsets we need to fix dtype to contain
965          sizeof(chartype) and fix the code below.  */
966       size = charlen;
967       kind = charlen;
968       break;
969     case GFC_DTYPE_DERIVED:
970       internal_error ("Derived type I/O should have been handled via the frontend.");
971       break;
972     default:
973       internal_error ("transfer_array(): Bad type");
974     }
975
976   if (desc->dim[0].stride == 0)
977     desc->dim[0].stride = 1;
978
979   rank = GFC_DESCRIPTOR_RANK (desc);
980   for (n = 0; n < rank; n++)
981     {
982       count[n] = 0;
983       stride[n] = desc->dim[n].stride;
984       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
985
986       /* If the extent of even one dimension is zero, then the entire
987          array section contains zero elements, so we return.  */
988       if (extent[n] == 0)
989         return;
990     }
991
992   stride0 = stride[0];
993
994   /* If the innermost dimension has stride 1, we can do the transfer
995      in contiguous chunks.  */
996   if (stride0 == 1)
997     tsize = extent[0];
998   else
999     tsize = 1;
1000
1001   data = GFC_DESCRIPTOR_DATA (desc);
1002
1003   while (data)
1004     {
1005       transfer (iotype, data, kind, tsize);
1006       data += stride0 * size * tsize;
1007       count[0] += tsize;
1008       n = 0;
1009       while (count[n] == extent[n])
1010         {
1011           count[n] = 0;
1012           data -= stride[n] * extent[n] * size;
1013           n++;
1014           if (n == rank)
1015             {
1016               data = NULL;
1017               break;
1018             }
1019           else
1020             {
1021               count[n]++;
1022               data += stride[n] * size;
1023             }
1024         }
1025     }
1026 }
1027
1028
1029 /* Preposition a sequential unformatted file while reading.  */
1030
1031 static void
1032 us_read (void)
1033 {
1034   char *p;
1035   int n;
1036   gfc_offset i;
1037
1038   n = sizeof (gfc_offset);
1039   p = salloc_r (current_unit->s, &n);
1040
1041   if (n == 0)
1042     return;  /* end of file */
1043
1044   if (p == NULL || n != sizeof (gfc_offset))
1045     {
1046       generate_error (ERROR_BAD_US, NULL);
1047       return;
1048     }
1049
1050   memcpy (&i, p, sizeof (gfc_offset));
1051   current_unit->bytes_left = i;
1052 }
1053
1054
1055 /* Preposition a sequential unformatted file while writing.  This
1056    amount to writing a bogus length that will be filled in later.  */
1057
1058 static void
1059 us_write (void)
1060 {
1061   char *p;
1062   int length;
1063
1064   length = sizeof (gfc_offset);
1065   p = salloc_w (current_unit->s, &length);
1066
1067   if (p == NULL)
1068     {
1069       generate_error (ERROR_OS, NULL);
1070       return;
1071     }
1072
1073   memset (p, '\0', sizeof (gfc_offset));        /* Bogus value for now.  */
1074   if (sfree (current_unit->s) == FAILURE)
1075     generate_error (ERROR_OS, NULL);
1076
1077   /* For sequential unformatted, we write until we have more bytes than
1078      can fit in the record markers. If disk space runs out first, it will
1079      error on the write.  */
1080   current_unit->recl = g.max_offset;
1081
1082   current_unit->bytes_left = current_unit->recl;
1083 }
1084
1085
1086 /* Position to the next record prior to transfer.  We are assumed to
1087    be before the next record.  We also calculate the bytes in the next
1088    record.  */
1089
1090 static void
1091 pre_position (void)
1092 {
1093   if (current_unit->current_record)
1094     return;                     /* Already positioned.  */
1095
1096   switch (current_mode ())
1097     {
1098     case UNFORMATTED_SEQUENTIAL:
1099       if (g.mode == READING)
1100         us_read ();
1101       else
1102         us_write ();
1103
1104       break;
1105
1106     case FORMATTED_SEQUENTIAL:
1107     case FORMATTED_DIRECT:
1108     case UNFORMATTED_DIRECT:
1109       current_unit->bytes_left = current_unit->recl;
1110       break;
1111     }
1112
1113   current_unit->current_record = 1;
1114 }
1115
1116
1117 /* Initialize things for a data transfer.  This code is common for
1118    both reading and writing.  */
1119
1120 static void
1121 data_transfer_init (int read_flag)
1122 {
1123   unit_flags u_flags;  /* Used for creating a unit if needed.  */
1124
1125   g.mode = read_flag ? READING : WRITING;
1126
1127   if (ioparm.size != NULL)
1128     *ioparm.size = 0;           /* Initialize the count.  */
1129
1130   current_unit = get_unit (read_flag);
1131   if (current_unit == NULL)
1132   {  /* Open the unit with some default flags.  */
1133      if (ioparm.unit < 0)
1134      {
1135        generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
1136        library_end ();
1137        return;
1138      }
1139      memset (&u_flags, '\0', sizeof (u_flags));
1140      u_flags.access = ACCESS_SEQUENTIAL;
1141      u_flags.action = ACTION_READWRITE;
1142      /* Is it unformatted?  */
1143      if (ioparm.format == NULL && !ioparm.list_format)
1144        u_flags.form = FORM_UNFORMATTED;
1145      else
1146        u_flags.form = FORM_UNSPECIFIED;
1147      u_flags.delim = DELIM_UNSPECIFIED;
1148      u_flags.blank = BLANK_UNSPECIFIED;
1149      u_flags.pad = PAD_UNSPECIFIED;
1150      u_flags.status = STATUS_UNKNOWN;
1151      new_unit(&u_flags);
1152      current_unit = get_unit (read_flag);
1153   }
1154
1155   if (current_unit == NULL)
1156     return;
1157
1158   /* Check the action.  */
1159
1160   if (read_flag && current_unit->flags.action == ACTION_WRITE)
1161     generate_error (ERROR_BAD_ACTION,
1162                     "Cannot read from file opened for WRITE");
1163
1164   if (!read_flag && current_unit->flags.action == ACTION_READ)
1165     generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
1166
1167   if (ioparm.library_return != LIBRARY_OK)
1168     return;
1169
1170   /* Check the format.  */
1171
1172   if (ioparm.format)
1173     parse_format ();
1174
1175   if (ioparm.library_return != LIBRARY_OK)
1176     return;
1177
1178   if (current_unit->flags.form == FORM_UNFORMATTED
1179       && (ioparm.format != NULL || ioparm.list_format))
1180     generate_error (ERROR_OPTION_CONFLICT,
1181                     "Format present for UNFORMATTED data transfer");
1182
1183   if (ioparm.namelist_name != NULL && ionml != NULL)
1184      {
1185         if(ioparm.format != NULL)
1186            generate_error (ERROR_OPTION_CONFLICT,
1187                     "A format cannot be specified with a namelist");
1188      }
1189   else if (current_unit->flags.form == FORM_FORMATTED &&
1190            ioparm.format == NULL && !ioparm.list_format)
1191     generate_error (ERROR_OPTION_CONFLICT,
1192                     "Missing format for FORMATTED data transfer");
1193
1194
1195   if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
1196     generate_error (ERROR_OPTION_CONFLICT,
1197                     "Internal file cannot be accessed by UNFORMATTED data transfer");
1198
1199   /* Check the record number.  */
1200
1201   if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
1202     {
1203       generate_error (ERROR_MISSING_OPTION,
1204                       "Direct access data transfer requires record number");
1205       return;
1206     }
1207
1208   if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
1209     {
1210       generate_error (ERROR_OPTION_CONFLICT,
1211                       "Record number not allowed for sequential access data transfer");
1212       return;
1213     }
1214
1215   /* Process the ADVANCE option.  */
1216
1217   advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
1218     find_option (ioparm.advance, ioparm.advance_len, advance_opt,
1219                  "Bad ADVANCE parameter in data transfer statement");
1220
1221   if (advance_status != ADVANCE_UNSPECIFIED)
1222     {
1223       if (current_unit->flags.access == ACCESS_DIRECT)
1224         generate_error (ERROR_OPTION_CONFLICT,
1225                         "ADVANCE specification conflicts with sequential access");
1226
1227       if (is_internal_unit ())
1228         generate_error (ERROR_OPTION_CONFLICT,
1229                         "ADVANCE specification conflicts with internal file");
1230
1231       if (ioparm.format == NULL || ioparm.list_format)
1232         generate_error (ERROR_OPTION_CONFLICT,
1233                         "ADVANCE specification requires an explicit format");
1234     }
1235
1236   if (read_flag)
1237     {
1238       if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
1239         generate_error (ERROR_MISSING_OPTION,
1240                         "EOR specification requires an ADVANCE specification of NO");
1241
1242       if (ioparm.size != NULL && advance_status != ADVANCE_NO)
1243         generate_error (ERROR_MISSING_OPTION,
1244                         "SIZE specification requires an ADVANCE specification of NO");
1245
1246     }
1247   else
1248     {                           /* Write constraints.  */
1249       if (ioparm.end != 0)
1250         generate_error (ERROR_OPTION_CONFLICT,
1251                         "END specification cannot appear in a write statement");
1252
1253       if (ioparm.eor != 0)
1254         generate_error (ERROR_OPTION_CONFLICT,
1255                         "EOR specification cannot appear in a write statement");
1256
1257       if (ioparm.size != 0)
1258         generate_error (ERROR_OPTION_CONFLICT,
1259                         "SIZE specification cannot appear in a write statement");
1260     }
1261
1262   if (advance_status == ADVANCE_UNSPECIFIED)
1263     advance_status = ADVANCE_YES;
1264   if (ioparm.library_return != LIBRARY_OK)
1265     return;
1266
1267   /* Sanity checks on the record number.  */
1268
1269   if (ioparm.rec)
1270     {
1271       if (ioparm.rec <= 0)
1272         {
1273           generate_error (ERROR_BAD_OPTION, "Record number must be positive");
1274           return;
1275         }
1276
1277       if (ioparm.rec >= current_unit->maxrec)
1278         {
1279           generate_error (ERROR_BAD_OPTION, "Record number too large");
1280           return;
1281         }
1282
1283       /* Check to see if we might be reading what we wrote before  */
1284
1285       if (g.mode == READING && current_unit->mode  == WRITING)
1286          flush(current_unit->s);
1287
1288       /* Check whether the record exists to be read.  Only
1289          a partial record needs to exist.  */
1290
1291       if (g.mode == READING && (ioparm.rec -1)
1292           * current_unit->recl >= file_length (current_unit->s))
1293         {
1294           generate_error (ERROR_BAD_OPTION, "Non-existing record number");
1295           return;
1296         }
1297
1298       /* Position the file.  */
1299       if (sseek (current_unit->s,
1300                (ioparm.rec - 1) * current_unit->recl) == FAILURE)
1301         {
1302           generate_error (ERROR_OS, NULL);
1303           return;
1304         }
1305     }
1306
1307   /* Overwriting an existing sequential file ?
1308      it is always safe to truncate the file on the first write */
1309   if (g.mode == WRITING
1310       && current_unit->flags.access == ACCESS_SEQUENTIAL
1311       && current_unit->last_record == 0 && !is_preconnected(current_unit->s))
1312         struncate(current_unit->s);
1313
1314   current_unit->mode = g.mode;
1315
1316   /* Set the initial value of flags.  */
1317
1318   g.blank_status = current_unit->flags.blank;
1319   g.sign_status = SIGN_S;
1320   g.scale_factor = 0;
1321   g.seen_dollar = 0;
1322   g.first_item = 1;
1323   g.item_count = 0;
1324   sf_seen_eor = 0;
1325   eor_condition = 0;
1326
1327   pre_position ();
1328
1329   /* Set up the subroutine that will handle the transfers.  */
1330
1331   if (read_flag)
1332     {
1333       if (current_unit->flags.form == FORM_UNFORMATTED)
1334         transfer = unformatted_read;
1335       else
1336         {
1337           if (ioparm.list_format)
1338             {
1339                transfer = list_formatted_read;
1340                init_at_eol();
1341             }
1342           else
1343             transfer = formatted_transfer;
1344         }
1345     }
1346   else
1347     {
1348       if (current_unit->flags.form == FORM_UNFORMATTED)
1349         transfer = unformatted_write;
1350       else
1351         {
1352           if (ioparm.list_format)
1353             transfer = list_formatted_write;
1354           else
1355             transfer = formatted_transfer;
1356         }
1357     }
1358
1359   /* Make sure that we don't do a read after a nonadvancing write.  */
1360
1361   if (read_flag)
1362     {
1363       if (current_unit->read_bad)
1364         {
1365           generate_error (ERROR_BAD_OPTION,
1366                           "Cannot READ after a nonadvancing WRITE");
1367           return;
1368         }
1369     }
1370   else
1371     {
1372       if (advance_status == ADVANCE_YES && !g.seen_dollar)
1373         current_unit->read_bad = 1;
1374     }
1375
1376   /* Reset counters for T and X-editing.  */
1377   max_pos = skips = pending_spaces = 0;
1378
1379   /* Start the data transfer if we are doing a formatted transfer.  */
1380   if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
1381       && ioparm.namelist_name == NULL && ionml == NULL)
1382     formatted_transfer (0, NULL, 0, 1);
1383 }
1384
1385
1386 /* Space to the next record for read mode.  If the file is not
1387    seekable, we read MAX_READ chunks until we get to the right
1388    position.  */
1389
1390 #define MAX_READ 4096
1391
1392 static void
1393 next_record_r (void)
1394 {
1395   int rlength, length, bytes_left;
1396   gfc_offset new;
1397   char *p;
1398
1399   switch (current_mode ())
1400     {
1401     case UNFORMATTED_SEQUENTIAL:
1402       current_unit->bytes_left += sizeof (gfc_offset);  /* Skip over tail */
1403
1404       /* Fall through...  */
1405
1406     case FORMATTED_DIRECT:
1407     case UNFORMATTED_DIRECT:
1408       if (current_unit->bytes_left == 0)
1409         break;
1410
1411       if (is_seekable (current_unit->s))
1412         {
1413           new = file_position (current_unit->s) + current_unit->bytes_left;
1414
1415           /* Direct access files do not generate END conditions,
1416              only I/O errors.  */
1417           if (sseek (current_unit->s, new) == FAILURE)
1418             generate_error (ERROR_OS, NULL);
1419
1420         }
1421       else
1422         {                       /* Seek by reading data.  */
1423           while (current_unit->bytes_left > 0)
1424             {
1425               rlength = length = (MAX_READ > current_unit->bytes_left) ?
1426                 MAX_READ : current_unit->bytes_left;
1427
1428               p = salloc_r (current_unit->s, &rlength);
1429               if (p == NULL)
1430                 {
1431                   generate_error (ERROR_OS, NULL);
1432                   break;
1433                 }
1434
1435               current_unit->bytes_left -= length;
1436             }
1437         }
1438       break;
1439
1440     case FORMATTED_SEQUENTIAL:
1441       length = 1;
1442       /* sf_read has already terminated input because of an '\n'  */
1443       if (sf_seen_eor)
1444         {
1445           sf_seen_eor=0;
1446           break;
1447         }
1448
1449       if (is_internal_unit())
1450         {
1451           bytes_left = (int) current_unit->bytes_left;
1452           p = salloc_r (current_unit->s, &bytes_left);
1453           if (p != NULL)
1454             current_unit->bytes_left = current_unit->recl;
1455           break;
1456         }
1457       else do
1458         {
1459           p = salloc_r (current_unit->s, &length);
1460
1461           if (p == NULL)
1462             {
1463               generate_error (ERROR_OS, NULL);
1464               break;
1465             }
1466
1467           if (length == 0)
1468             {
1469               current_unit->endfile = AT_ENDFILE;
1470               break;
1471             }
1472         }
1473       while (*p != '\n');
1474
1475       break;
1476     }
1477
1478   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1479     test_endfile (current_unit);
1480 }
1481
1482
1483 /* Position to the next record in write mode.  */
1484
1485 static void
1486 next_record_w (void)
1487 {
1488   gfc_offset c, m;
1489   int length, bytes_left;
1490   char *p;
1491
1492   /* Zero counters for X- and T-editing.  */
1493   max_pos = skips = pending_spaces = 0;
1494
1495   switch (current_mode ())
1496     {
1497     case FORMATTED_DIRECT:
1498       if (current_unit->bytes_left == 0)
1499         break;
1500
1501       length = current_unit->bytes_left;
1502       p = salloc_w (current_unit->s, &length);
1503
1504       if (p == NULL)
1505         goto io_error;
1506
1507       memset (p, ' ', current_unit->bytes_left);
1508       if (sfree (current_unit->s) == FAILURE)
1509         goto io_error;
1510       break;
1511
1512     case UNFORMATTED_DIRECT:
1513       if (sfree (current_unit->s) == FAILURE)
1514         goto io_error;
1515       break;
1516
1517     case UNFORMATTED_SEQUENTIAL:
1518       m = current_unit->recl - current_unit->bytes_left; /* Bytes written.  */
1519       c = file_position (current_unit->s);
1520
1521       length = sizeof (gfc_offset);
1522
1523       /* Write the length tail.  */
1524
1525       p = salloc_w (current_unit->s, &length);
1526       if (p == NULL)
1527         goto io_error;
1528
1529       memcpy (p, &m, sizeof (gfc_offset));
1530       if (sfree (current_unit->s) == FAILURE)
1531         goto io_error;
1532
1533       /* Seek to the head and overwrite the bogus length with the real
1534          length.  */
1535
1536       p = salloc_w_at (current_unit->s, &length, c - m - length);
1537       if (p == NULL)
1538         generate_error (ERROR_OS, NULL);
1539
1540       memcpy (p, &m, sizeof (gfc_offset));
1541       if (sfree (current_unit->s) == FAILURE)
1542         goto io_error;
1543
1544       /* Seek past the end of the current record.  */
1545
1546       if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1547         goto io_error;
1548
1549       break;
1550
1551     case FORMATTED_SEQUENTIAL:
1552
1553       if (current_unit->bytes_left == 0)
1554         break;
1555         
1556       if (is_internal_unit())
1557         {
1558           if (is_array_io())
1559             {
1560               bytes_left = (int) current_unit->bytes_left;
1561               p = salloc_w (current_unit->s, &bytes_left);
1562               if (p != NULL)
1563                 {
1564                   memset(p, ' ', bytes_left);
1565                   current_unit->bytes_left = current_unit->recl;
1566                 }
1567             }
1568           else
1569             {
1570               length = 1;
1571               p = salloc_w (current_unit->s, &length);
1572             }
1573         }
1574       else
1575         {
1576 #ifdef HAVE_CRLF
1577           length = 2;
1578 #else
1579           length = 1;
1580 #endif
1581           p = salloc_w (current_unit->s, &length);
1582           if (p)
1583             {  /* No new line for internal writes.  */
1584 #ifdef HAVE_CRLF
1585               p[0] = '\r';
1586               p[1] = '\n';
1587 #else
1588               *p = '\n';
1589 #endif
1590             }
1591           else
1592             goto io_error;
1593         }
1594
1595       break;
1596
1597     io_error:
1598       generate_error (ERROR_OS, NULL);
1599       break;
1600     }
1601 }
1602
1603
1604 /* Position to the next record, which means moving to the end of the
1605    current record.  This can happen under several different
1606    conditions.  If the done flag is not set, we get ready to process
1607    the next record.  */
1608
1609 void
1610 next_record (int done)
1611 {
1612   gfc_offset fp; /* File position.  */
1613
1614   current_unit->read_bad = 0;
1615
1616   if (g.mode == READING)
1617     next_record_r ();
1618   else
1619     next_record_w ();
1620
1621   /* keep position up to date for INQUIRE */
1622   current_unit->flags.position = POSITION_ASIS;
1623
1624   current_unit->current_record = 0;
1625   if (current_unit->flags.access == ACCESS_DIRECT)
1626    {
1627     fp = file_position (current_unit->s);
1628     /* Calculate next record, rounding up partial records.  */
1629     current_unit->last_record = (fp + current_unit->recl - 1)
1630                                 / current_unit->recl;
1631    }
1632   else
1633     current_unit->last_record++;
1634
1635   if (!done)
1636     pre_position ();
1637 }
1638
1639
1640 /* Finalize the current data transfer.  For a nonadvancing transfer,
1641    this means advancing to the next record.  For internal units close the
1642    steam associated with the unit.  */
1643
1644 static void
1645 finalize_transfer (void)
1646 {
1647
1648   if (eor_condition)
1649     {
1650       generate_error (ERROR_EOR, NULL);
1651       return;
1652     }
1653
1654   if (ioparm.library_return != LIBRARY_OK)
1655     return;
1656
1657   if ((ionml != NULL) && (ioparm.namelist_name != NULL))
1658     {
1659        if (ioparm.namelist_read_mode)
1660          namelist_read();
1661        else
1662          namelist_write();
1663     }
1664
1665   transfer = NULL;
1666   if (current_unit == NULL)
1667     return;
1668
1669   if (setjmp (g.eof_jump))
1670     {
1671       generate_error (ERROR_END, NULL);
1672       return;
1673     }
1674
1675   if (ioparm.list_format && g.mode == READING)
1676     finish_list_read ();
1677   else
1678     {
1679       free_fnodes ();
1680
1681       if (advance_status == ADVANCE_NO || g.seen_dollar)
1682         {
1683           /* Most systems buffer lines, so force the partial record
1684              to be written out.  */
1685           flush (current_unit->s);
1686           g.seen_dollar = 0;
1687           return;
1688         }
1689
1690       next_record (1);
1691       current_unit->current_record = 0;
1692     }
1693
1694   sfree (current_unit->s);
1695
1696   if (is_internal_unit ())
1697     sclose (current_unit->s);
1698 }
1699
1700
1701 /* Transfer function for IOLENGTH. It doesn't actually do any
1702    data transfer, it just updates the length counter.  */
1703
1704 static void
1705 iolength_transfer (bt type, void *dest __attribute__ ((unused)),
1706                    int len, size_t nelems)
1707 {
1708   if (ioparm.iolength != NULL)
1709     {
1710       if (type == BT_COMPLEX)
1711         *ioparm.iolength += 2 * len * nelems;
1712       else
1713         *ioparm.iolength += len * nelems;
1714     }
1715 }
1716
1717
1718 /* Initialize the IOLENGTH data transfer. This function is in essence
1719    a very much simplified version of data_transfer_init(), because it
1720    doesn't have to deal with units at all.  */
1721
1722 static void
1723 iolength_transfer_init (void)
1724 {
1725   if (ioparm.iolength != NULL)
1726     *ioparm.iolength = 0;
1727
1728   g.item_count = 0;
1729
1730   /* Set up the subroutine that will handle the transfers.  */
1731
1732   transfer = iolength_transfer;
1733 }
1734
1735
1736 /* Library entry point for the IOLENGTH form of the INQUIRE
1737    statement. The IOLENGTH form requires no I/O to be performed, but
1738    it must still be a runtime library call so that we can determine
1739    the iolength for dynamic arrays and such.  */
1740
1741 extern void st_iolength (void);
1742 export_proto(st_iolength);
1743
1744 void
1745 st_iolength (void)
1746 {
1747   library_start ();
1748   iolength_transfer_init ();
1749 }
1750
1751 extern void st_iolength_done (void);
1752 export_proto(st_iolength_done);
1753
1754 void
1755 st_iolength_done (void)
1756 {
1757   library_end ();
1758 }
1759
1760
1761 /* The READ statement.  */
1762
1763 extern void st_read (void);
1764 export_proto(st_read);
1765
1766 void
1767 st_read (void)
1768 {
1769
1770   library_start ();
1771
1772   data_transfer_init (1);
1773
1774   /* Handle complications dealing with the endfile record.  It is
1775      significant that this is the only place where ERROR_END is
1776      generated.  Reading an end of file elsewhere is either end of
1777      record or an I/O error. */
1778
1779   if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1780     switch (current_unit->endfile)
1781       {
1782       case NO_ENDFILE:
1783         break;
1784
1785       case AT_ENDFILE:
1786         if (!is_internal_unit())
1787           {
1788             generate_error (ERROR_END, NULL);
1789             current_unit->endfile = AFTER_ENDFILE;
1790           }
1791         break;
1792
1793       case AFTER_ENDFILE:
1794         generate_error (ERROR_ENDFILE, NULL);
1795         break;
1796       }
1797 }
1798
1799 extern void st_read_done (void);
1800 export_proto(st_read_done);
1801
1802 void
1803 st_read_done (void)
1804 {
1805   finalize_transfer ();
1806   library_end ();
1807 }
1808
1809 extern void st_write (void);
1810 export_proto(st_write);
1811
1812 void
1813 st_write (void)
1814 {
1815
1816   library_start ();
1817   data_transfer_init (0);
1818 }
1819
1820 extern void st_write_done (void);
1821 export_proto(st_write_done);
1822
1823 void
1824 st_write_done (void)
1825 {
1826   finalize_transfer ();
1827
1828   /* Deal with endfile conditions associated with sequential files.  */
1829
1830   if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
1831     switch (current_unit->endfile)
1832       {
1833       case AT_ENDFILE:          /* Remain at the endfile record.  */
1834         break;
1835
1836       case AFTER_ENDFILE:
1837         current_unit->endfile = AT_ENDFILE;     /* Just at it now.  */
1838         break;
1839
1840       case NO_ENDFILE:
1841         if (current_unit->current_record > current_unit->last_record)
1842           {
1843             /* Get rid of whatever is after this record.  */
1844             if (struncate (current_unit->s) == FAILURE)
1845               generate_error (ERROR_OS, NULL);
1846           }
1847
1848         current_unit->endfile = AT_ENDFILE;
1849         break;
1850       }
1851
1852   library_end ();
1853 }
1854
1855 /* Receives the scalar information for namelist objects and stores it
1856    in a linked list of namelist_info types.  */
1857
1858 extern void st_set_nml_var (void * ,char * ,
1859                             GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
1860 export_proto(st_set_nml_var);
1861
1862
1863 void
1864 st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
1865                 gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
1866 {
1867   namelist_info *t1 = NULL;
1868   namelist_info *nml;
1869
1870   nml = (namelist_info*) get_mem (sizeof (namelist_info));
1871
1872   nml->mem_pos = var_addr;
1873
1874   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
1875   strcpy (nml->var_name, var_name);
1876
1877   nml->len = (int) len;
1878   nml->string_length = (index_type) string_length;
1879
1880   nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
1881   nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
1882   nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
1883
1884   if (nml->var_rank > 0)
1885     {
1886       nml->dim = (descriptor_dimension*)
1887                    get_mem (nml->var_rank * sizeof (descriptor_dimension));
1888       nml->ls = (nml_loop_spec*)
1889                   get_mem (nml->var_rank * sizeof (nml_loop_spec));
1890     }
1891   else
1892     {
1893       nml->dim = NULL;
1894       nml->ls = NULL;
1895     }
1896
1897   nml->next = NULL;
1898
1899   if (ionml == NULL)
1900     ionml = nml;
1901   else
1902     {
1903       for (t1 = ionml; t1->next; t1 = t1->next);
1904       t1->next = nml;
1905     }
1906   return;
1907 }
1908
1909 /* Store the dimensional information for the namelist object.  */
1910 extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
1911                                 GFC_INTEGER_4 ,GFC_INTEGER_4);
1912 export_proto(st_set_nml_var_dim);
1913
1914 void
1915 st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
1916                     GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
1917 {
1918   namelist_info * nml;
1919   int n;
1920
1921   n = (int)n_dim;
1922
1923   for (nml = ionml; nml->next; nml = nml->next);
1924
1925   nml->dim[n].stride = (ssize_t)stride;
1926   nml->dim[n].lbound = (ssize_t)lbound;
1927   nml->dim[n].ubound = (ssize_t)ubound;
1928 }