OSDN Git Service

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