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