OSDN Git Service

384df36f6c42f16d384956d444ac238f7a2f97bf
[pf3gnuchains/gcc-fork.git] / libgfortran / io / list_read.c
1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
10
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file.  (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
18 executable.)
19
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 GNU General Public License for more details.
24
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING.  If not, write to
27 the Free Software Foundation, 59 Temple Place - Suite 330,
28 Boston, MA 02111-1307, USA.  */
29
30
31 #include "config.h"
32 #include <string.h>
33 #include <ctype.h>
34 #include "libgfortran.h"
35 #include "io.h"
36
37
38 /* List directed input.  Several parsing subroutines are practically
39    reimplemented from formatted input, the reason being that there are
40    all kinds of small differences between formatted and list directed
41    parsing.  */
42
43
44 /* Subroutines for reading characters from the input.  Because a
45    repeat count is ambiguous with an integer, we have to read the
46    whole digit string before seeing if there is a '*' which signals
47    the repeat count.  Since we can have a lot of potential leading
48    zeros, we have to be able to back up by arbitrary amount.  Because
49    the input might not be seekable, we have to buffer the data
50    ourselves.  Data is buffered in scratch[] until it becomes too
51    large, after which we start allocating memory on the heap.  */
52
53 static int repeat_count, saved_length, saved_used, input_complete, at_eol;
54 static int comma_flag, namelist_mode;
55
56 static char last_char, *saved_string;
57 static bt saved_type;
58
59
60
61 /* Storage area for values except for strings.  Must be large enough
62    to hold a complex value (two reals) of the largest kind.  */
63
64 static char value[20];
65
66 #define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
67                       case '5': case '6': case '7': case '8': case '9'
68
69 #define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t': \
70                          case '\r'
71
72 /* This macro assumes that we're operating on a variable.  */
73
74 #define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
75                          || c == '\t' || c == '\r')
76
77 /* Maximum repeat count.  Less than ten times the maximum signed int32.  */
78
79 #define MAX_REPEAT 200000000
80
81
82 /* Save a character to a string buffer, enlarging it as necessary.  */
83
84 static void
85 push_char (char c)
86 {
87   char *new;
88
89   if (saved_string == NULL)
90     {
91       saved_string = scratch;
92       memset (saved_string,0,SCRATCH_SIZE);
93       saved_length = SCRATCH_SIZE;
94       saved_used = 0;
95     }
96
97   if (saved_used >= saved_length)
98     {
99       saved_length = 2 * saved_length;
100       new = get_mem (2 * saved_length);
101
102       memset (new,0,2 * saved_length);
103
104       memcpy (new, saved_string, saved_used);
105       if (saved_string != scratch)
106         free_mem (saved_string);
107
108       saved_string = new;
109     }
110
111   saved_string[saved_used++] = c;
112 }
113
114
115 /* Free the input buffer if necessary.  */
116
117 static void
118 free_saved (void)
119 {
120   if (saved_string == NULL)
121     return;
122
123   if (saved_string != scratch)
124     free_mem (saved_string);
125
126   saved_string = NULL;
127 }
128
129
130 static char
131 next_char (void)
132 {
133   int length;
134   char c, *p;
135
136   if (last_char != '\0')
137     {
138       at_eol = 0;
139       c = last_char;
140       last_char = '\0';
141       goto done;
142     }
143
144   length = 1;
145
146   p = salloc_r (current_unit->s, &length);
147   if (p == NULL)
148     {
149       generate_error (ERROR_OS, NULL);
150       return '\0';
151     }
152
153   if (length == 0)
154     {
155       /* For internal files return a newline instead of signalling EOF.  */
156       /* ??? This isn't quite right, but we don't handle internal files
157          with multiple records.  */
158       if (is_internal_unit ())
159         c = '\n';
160       else
161         longjmp (g.eof_jump, 1);
162     }
163   else
164     c = *p;
165
166 done:
167   at_eol = (c == '\n' || c == '\r');
168   return c;
169 }
170
171
172 /* Push a character back onto the input.  */
173
174 static void
175 unget_char (char c)
176 {
177   last_char = c;
178 }
179
180
181 /* Skip over spaces in the input.  Returns the nonspace character that
182    terminated the eating and also places it back on the input.  */
183
184 static char
185 eat_spaces (void)
186 {
187   char c;
188
189   do
190     {
191       c = next_char ();
192     }
193   while (c == ' ' || c == '\t');
194
195   unget_char (c);
196   return c;
197 }
198
199
200 /* Skip over a separator.  Technically, we don't always eat the whole
201    separator.  This is because if we've processed the last input item,
202    then a separator is unnecessary.  Plus the fact that operating
203    systems usually deliver console input on a line basis.
204
205    The upshot is that if we see a newline as part of reading a
206    separator, we stop reading.  If there are more input items, we
207    continue reading the separator with finish_separator() which takes
208    care of the fact that we may or may not have seen a comma as part
209    of the separator.  */
210
211 static void
212 eat_separator (void)
213 {
214   char c;
215
216   eat_spaces ();
217   comma_flag = 0;
218
219   c = next_char ();
220   switch (c)
221     {
222     case ',':
223       comma_flag = 1;
224       eat_spaces ();
225       break;
226
227     case '/':
228       input_complete = 1;
229       next_record (0);
230       at_eol = 1;
231       break;
232
233     case '\n':
234     case '\r':
235       break;
236
237     case '!':
238       if (namelist_mode)
239         {                       /* Eat a namelist comment.  */
240           do
241             c = next_char ();
242           while (c != '\n');
243
244           break;
245         }
246
247       /* Fall Through...  */
248
249     default:
250       unget_char (c);
251       break;
252     }
253 }
254
255
256 /* Finish processing a separator that was interrupted by a newline.
257    If we're here, then another data item is present, so we finish what
258    we started on the previous line.  */
259
260 static void
261 finish_separator (void)
262 {
263   char c;
264
265  restart:
266   eat_spaces ();
267
268   c = next_char ();
269   switch (c)
270     {
271     case ',':
272       if (comma_flag)
273         unget_char (c);
274       else
275         {
276           c = eat_spaces ();
277           if (c == '\n')
278             goto restart;
279         }
280
281       break;
282
283     case '/':
284       input_complete = 1;
285       next_record (0);
286       break;
287
288     case '\n':
289     case '\r':
290       goto restart;
291
292     case '!':
293       if (namelist_mode)
294         {
295           do
296             c = next_char ();
297           while (c != '\n');
298
299           goto restart;
300         }
301
302     default:
303       unget_char (c);
304       break;
305     }
306 }
307
308
309 /* Convert an unsigned string to an integer.  The length value is -1
310    if we are working on a repeat count.  Returns nonzero if we have a
311    range problem.  As a side effect, frees the saved_string.  */
312
313 static int
314 convert_integer (int length, int negative)
315 {
316   char c, *buffer, message[100];
317   int m;
318   int64_t v, max, max10;
319
320   buffer = saved_string;
321   v = 0;
322
323   max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
324   max10 = max / 10;
325
326   for (;;)
327     {
328       c = *buffer++;
329       if (c == '\0')
330         break;
331       c -= '0';
332
333       if (v > max10)
334         goto overflow;
335       v = 10 * v;
336
337       if (v > max - c)
338         goto overflow;
339       v += c;
340     }
341
342   m = 0;
343
344   if (length != -1)
345     {
346       if (negative)
347         v = -v;
348       set_integer (value, v, length);
349     }
350   else
351     {
352       repeat_count = v;
353
354       if (repeat_count == 0)
355         {
356           st_sprintf (message, "Zero repeat count in item %d of list input",
357                       g.item_count);
358
359           generate_error (ERROR_READ_VALUE, message);
360           m = 1;
361         }
362     }
363
364   free_saved ();
365   return m;
366
367  overflow:
368   if (length == -1)
369     st_sprintf (message, "Repeat count overflow in item %d of list input",
370                 g.item_count);
371   else
372     st_sprintf (message, "Integer overflow while reading item %d",
373                 g.item_count);
374
375   free_saved ();
376   generate_error (ERROR_READ_VALUE, message);
377
378   return 1;
379 }
380
381
382 /* Parse a repeat count for logical and complex values which cannot
383    begin with a digit.  Returns nonzero if we are done, zero if we
384    should continue on.  */
385
386 static int
387 parse_repeat (void)
388 {
389   char c, message[100];
390   int repeat;
391
392   c = next_char ();
393   switch (c)
394     {
395     CASE_DIGITS:
396       repeat = c - '0';
397       break;
398
399     CASE_SEPARATORS:
400       unget_char (c);
401       eat_separator ();
402       return 1;
403
404     default:
405       unget_char (c);
406       return 0;
407     }
408
409   for (;;)
410     {
411       c = next_char ();
412       switch (c)
413         {
414         CASE_DIGITS:
415           repeat = 10 * repeat + c - '0';
416
417           if (repeat > MAX_REPEAT)
418             {
419               st_sprintf (message,
420                           "Repeat count overflow in item %d of list input",
421                           g.item_count);
422
423               generate_error (ERROR_READ_VALUE, message);
424               return 1;
425             }
426
427           break;
428
429         case '*':
430           if (repeat == 0)
431             {
432               st_sprintf (message,
433                           "Zero repeat count in item %d of list input",
434                           g.item_count);
435
436               generate_error (ERROR_READ_VALUE, message);
437               return 1;
438             }
439
440           goto done;
441
442         default:
443           goto bad_repeat;
444         }
445     }
446
447  done:
448   repeat_count = repeat;
449   return 0;
450
451  bad_repeat:
452   st_sprintf (message, "Bad repeat count in item %d of list input",
453               g.item_count);
454
455   generate_error (ERROR_READ_VALUE, message);
456   return 1;
457 }
458
459
460 /* Read a logical character on the input.  */
461
462 static void
463 read_logical (int length)
464 {
465   char c, message[100];
466   int v;
467
468   if (parse_repeat ())
469     return;
470
471   c = next_char ();
472   switch (c)
473     {
474     case 't':
475     case 'T':
476       v = 1;
477       break;
478     case 'f':
479     case 'F':
480       v = 0;
481       break;
482
483     case '.':
484       c = next_char ();
485       switch (c)
486         {
487         case 't':
488         case 'T':
489           v = 1;
490           break;
491         case 'f':
492         case 'F':
493           v = 0;
494           break;
495         default:
496           goto bad_logical;
497         }
498
499       break;
500
501     CASE_SEPARATORS:
502       unget_char (c);
503       eat_separator ();
504       return;                   /* Null value.  */
505
506     default:
507       goto bad_logical;
508     }
509
510   saved_type = BT_LOGICAL;
511   saved_length = length;
512
513   /* Eat trailing garbage.  */
514   do
515     {
516       c = next_char ();
517     }
518   while (!is_separator (c));
519
520   unget_char (c);
521   eat_separator ();
522   free_saved ();
523   set_integer ((int *) value, v, length);
524
525   return;
526
527  bad_logical:
528   st_sprintf (message, "Bad logical value while reading item %d",
529               g.item_count);
530
531   generate_error (ERROR_READ_VALUE, message);
532 }
533
534
535 /* Reading integers is tricky because we can actually be reading a
536    repeat count.  We have to store the characters in a buffer because
537    we could be reading an integer that is larger than the default int
538    used for repeat counts.  */
539
540 static void
541 read_integer (int length)
542 {
543   char c, message[100];
544   int negative;
545
546   negative = 0;
547
548   c = next_char ();
549   switch (c)
550     {
551     case '-':
552       negative = 1;
553       /* Fall through...  */
554
555     case '+':
556       c = next_char ();
557       goto get_integer;
558
559     CASE_SEPARATORS:            /* Single null.  */
560       unget_char (c);
561       eat_separator ();
562       return;
563
564     CASE_DIGITS:
565       push_char (c);
566       break;
567
568     default:
569       goto bad_integer;
570     }
571
572   /* Take care of what may be a repeat count.  */
573
574   for (;;)
575     {
576       c = next_char ();
577       switch (c)
578         {
579         CASE_DIGITS:
580           push_char (c);
581           break;
582
583         case '*':
584           push_char ('\0');
585           goto repeat;
586
587         CASE_SEPARATORS:        /* Not a repeat count.  */
588           goto done;
589
590         default:
591           goto bad_integer;
592         }
593     }
594
595  repeat:
596   if (convert_integer (-1, 0))
597     return;
598
599   /* Get the real integer.  */
600
601   c = next_char ();
602   switch (c)
603     {
604     CASE_DIGITS:
605       break;
606
607     CASE_SEPARATORS:
608       unget_char (c);
609       eat_separator ();
610       return;
611
612     case '-':
613       negative = 1;
614       /* Fall through...  */
615
616     case '+':
617       c = next_char ();
618       break;
619     }
620
621  get_integer:
622   if (!isdigit (c))
623     goto bad_integer;
624   push_char (c);
625
626   for (;;)
627     {
628       c = next_char ();
629       switch (c)
630         {
631         CASE_DIGITS:
632           push_char (c);
633           break;
634
635         CASE_SEPARATORS:
636           goto done;
637
638         default:
639           goto bad_integer;
640         }
641     }
642
643  bad_integer:
644   free_saved ();
645
646   st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
647   generate_error (ERROR_READ_VALUE, message);
648
649   return;
650
651  done:
652   unget_char (c);
653   eat_separator ();
654
655   push_char ('\0');
656   if (convert_integer (length, negative))
657     {
658        free_saved ();
659        return;
660     }
661
662   free_saved ();
663   saved_type = BT_INTEGER;
664 }
665
666
667 /* Read a character variable.  */
668
669 static void
670 read_character (int length)
671 {
672   char c, quote, message[100];
673
674   quote = ' ';                  /* Space means no quote character.  */
675
676   c = next_char ();
677   switch (c)
678     {
679     CASE_DIGITS:
680       push_char (c);
681       break;
682
683     CASE_SEPARATORS:
684       unget_char (c);           /* NULL value.  */
685       eat_separator ();
686       return;
687
688     case '"':
689     case '\'':
690       quote = c;
691       goto get_string;
692
693     default:
694       push_char (c);
695       goto get_string;
696     }
697
698   /* Deal with a possible repeat count.  */
699
700   for (;;)
701     {
702       c = next_char ();
703       switch (c)
704         {
705         CASE_DIGITS:
706           push_char (c);
707           break;
708
709         CASE_SEPARATORS:
710           unget_char (c);
711           goto done;            /* String was only digits!  */
712
713         case '*':
714           push_char ('\0');
715           goto got_repeat;
716
717         default:
718           push_char (c);
719           goto get_string;      /* Not a repeat count after all.  */
720         }
721     }
722
723  got_repeat:
724   if (convert_integer (-1, 0))
725     return;
726
727   /* Now get the real string.  */
728
729   c = next_char ();
730   switch (c)
731     {
732     CASE_SEPARATORS:
733       unget_char (c);           /* Repeated NULL values.  */
734       eat_separator ();
735       return;
736
737     case '"':
738     case '\'':
739       quote = c;
740       break;
741
742     default:
743       push_char (c);
744       break;
745     }
746
747  get_string:
748   for (;;)
749     {
750       c = next_char ();
751       switch (c)
752         {
753         case '"':
754         case '\'':
755           if (c != quote)
756             {
757               push_char (c);
758               break;
759             }
760
761           /* See if we have a doubled quote character or the end of
762              the string.  */
763
764           c = next_char ();
765           if (c == quote)
766             {
767               push_char (quote);
768               break;
769             }
770
771           unget_char (c);
772           goto done;
773
774         CASE_SEPARATORS:
775           if (quote == ' ')
776             {
777               unget_char (c);
778               goto done;
779             }
780
781           if (c != '\n')
782             push_char (c);
783           break;
784
785         default:
786           push_char (c);
787           break;
788         }
789     }
790
791   /* At this point, we have to have a separator, or else the string is
792      invalid.  */
793  done:
794   c = next_char ();
795   if (is_separator (c))
796     {
797       unget_char (c);
798       eat_separator ();
799       saved_type = BT_CHARACTER;
800     }
801   else
802     {
803       free_saved ();
804       st_sprintf (message, "Invalid string input in item %d", g.item_count);
805       generate_error (ERROR_READ_VALUE, message);
806     }
807 }
808
809
810 /* Parse a component of a complex constant or a real number that we
811    are sure is already there.  This is a straight real number parser.  */
812
813 static int
814 parse_real (void *buffer, int length)
815 {
816   char c, message[100];
817   int m, seen_dp;
818
819   c = next_char ();
820   if (c == '-' || c == '+')
821     {
822       push_char (c);
823       c = next_char ();
824     }
825
826   if (!isdigit (c) && c != '.')
827     goto bad;
828
829   push_char (c);
830
831   seen_dp = (c == '.') ? 1 : 0;
832
833   for (;;)
834     {
835       c = next_char ();
836       switch (c)
837         {
838         CASE_DIGITS:
839           push_char (c);
840           break;
841
842         case '.':
843           if (seen_dp)
844             goto bad;
845
846           seen_dp = 1;
847           push_char (c);
848           break;
849
850         case 'e':
851         case 'E':
852         case 'd':
853         case 'D':
854           push_char ('e');
855           goto exp1;
856
857         case '-':
858         case '+':
859           push_char ('e');
860           push_char (c);
861           c = next_char ();
862           goto exp2;
863
864         CASE_SEPARATORS:
865           unget_char (c);
866           goto done;
867
868         default:
869           goto done;
870         }
871     }
872
873  exp1:
874   c = next_char ();
875   if (c != '-' && c != '+')
876     push_char ('+');
877   else
878     {
879       push_char (c);
880       c = next_char ();
881     }
882
883  exp2:
884   if (!isdigit (c))
885     goto bad;
886   push_char (c);
887
888   for (;;)
889     {
890       c = next_char ();
891       switch (c)
892         {
893         CASE_DIGITS:
894           push_char (c);
895           break;
896
897         CASE_SEPARATORS:
898           unget_char (c);
899           goto done;
900
901         default:
902           goto done;
903         }
904     }
905
906  done:
907   unget_char (c);
908   push_char ('\0');
909
910   m = convert_real (buffer, saved_string, length);
911   free_saved ();
912
913   return m;
914
915  bad:
916   free_saved ();
917   st_sprintf (message, "Bad floating point number for item %d", g.item_count);
918   generate_error (ERROR_READ_VALUE, message);
919
920   return 1;
921 }
922
923
924 /* Reading a complex number is straightforward because we can tell
925    what it is right away.  */
926
927 static void
928 read_complex (int length)
929 {
930   char message[100];
931   char c;
932
933   if (parse_repeat ())
934     return;
935
936   c = next_char ();
937   switch (c)
938     {
939     case '(':
940       break;
941
942     CASE_SEPARATORS:
943       unget_char (c);
944       eat_separator ();
945       return;
946
947     default:
948       goto bad_complex;
949     }
950
951   eat_spaces ();
952   if (parse_real (value, length))
953     return;
954
955   eat_spaces ();
956   if (next_char () != ',')
957     goto bad_complex;
958
959   eat_spaces ();
960   if (parse_real (value + length, length))
961     return;
962
963   eat_spaces ();
964   if (next_char () != ')')
965     goto bad_complex;
966
967   c = next_char ();
968   if (!is_separator (c))
969     goto bad_complex;
970
971   unget_char (c);
972   eat_separator ();
973
974   free_saved ();
975   saved_type = BT_COMPLEX;
976   return;
977
978  bad_complex:
979   st_sprintf (message, "Bad complex value in item %d of list input",
980               g.item_count);
981
982   generate_error (ERROR_READ_VALUE, message);
983 }
984
985
986 /* Parse a real number with a possible repeat count.  */
987
988 static void
989 read_real (int length)
990 {
991   char c, message[100];
992   int seen_dp;
993
994   seen_dp = 0;
995
996   c = next_char ();
997   switch (c)
998     {
999     CASE_DIGITS:
1000       push_char (c);
1001       break;
1002
1003     case '.':
1004       push_char (c);
1005       seen_dp = 1;
1006       break;
1007
1008     case '+':
1009     case '-':
1010       goto got_sign;
1011
1012     CASE_SEPARATORS:
1013       unget_char (c);           /* Single null.  */
1014       eat_separator ();
1015       return;
1016
1017     default:
1018       goto bad_real;
1019     }
1020
1021   /* Get the digit string that might be a repeat count.  */
1022
1023   for (;;)
1024     {
1025       c = next_char ();
1026       switch (c)
1027         {
1028         CASE_DIGITS:
1029           push_char (c);
1030           break;
1031
1032         case '.':
1033           if (seen_dp)
1034             goto bad_real;
1035
1036           seen_dp = 1;
1037           push_char (c);
1038           goto real_loop;
1039
1040         case 'E':
1041         case 'e':
1042         case 'D':
1043         case 'd':
1044           goto exp1;
1045
1046         case '+':
1047         case '-':
1048           push_char ('e');
1049           push_char (c);
1050           c = next_char ();
1051           goto exp2;
1052
1053         case '*':
1054           push_char ('\0');
1055           goto got_repeat;
1056
1057         CASE_SEPARATORS:
1058           if (c != '\n' &&  c != ',' && c != '\r')
1059             unget_char (c);
1060           goto done;
1061
1062         default:
1063           goto bad_real;
1064         }
1065     }
1066
1067  got_repeat:
1068   if (convert_integer (-1, 0))
1069     return;
1070
1071   /* Now get the number itself.  */
1072
1073   c = next_char ();
1074   if (is_separator (c))
1075     {                           /* Repeated null value.  */
1076       unget_char (c);
1077       eat_separator ();
1078       return;
1079     }
1080
1081   if (c != '-' && c != '+')
1082     push_char ('+');
1083   else
1084     {
1085     got_sign:
1086       push_char (c);
1087       c = next_char ();
1088     }
1089
1090   if (!isdigit (c) && c != '.')
1091     goto bad_real;
1092
1093   if (c == '.')
1094     {
1095       if (seen_dp)
1096         goto bad_real;
1097       else
1098         seen_dp = 1;
1099     }
1100
1101   push_char (c);
1102
1103  real_loop:
1104   for (;;)
1105     {
1106       c = next_char ();
1107       switch (c)
1108         {
1109         CASE_DIGITS:
1110           push_char (c);
1111           break;
1112
1113         CASE_SEPARATORS:
1114           goto done;
1115
1116         case '.':
1117           if (seen_dp)
1118             goto bad_real;
1119
1120           seen_dp = 1;
1121           push_char (c);
1122           break;
1123
1124         case 'E':
1125         case 'e':
1126         case 'D':
1127         case 'd':
1128           goto exp1;
1129
1130         case '+':
1131         case '-':
1132           push_char ('e');
1133           push_char (c);
1134           c = next_char ();
1135           goto exp2;
1136
1137         default:
1138           goto bad_real;
1139         }
1140     }
1141
1142  exp1:
1143   push_char ('e');
1144
1145   c = next_char ();
1146   if (c != '+' && c != '-')
1147     push_char ('+');
1148   else
1149     {
1150       push_char (c);
1151       c = next_char ();
1152     }
1153
1154  exp2:
1155   if (!isdigit (c))
1156     goto bad_real;
1157   push_char (c);
1158
1159   for (;;)
1160     {
1161       c = next_char ();
1162
1163       switch (c)
1164         {
1165         CASE_DIGITS:
1166           push_char (c);
1167           break;
1168
1169         CASE_SEPARATORS:
1170           goto done;
1171
1172         default:
1173           goto bad_real;
1174         }
1175     }
1176
1177  done:
1178   unget_char (c);
1179   eat_separator ();
1180   push_char ('\0');
1181   if (convert_real (value, saved_string, length))
1182     return;
1183
1184   free_saved ();
1185   saved_type = BT_REAL;
1186   return;
1187
1188  bad_real:
1189   st_sprintf (message, "Bad real number in item %d of list input",
1190               g.item_count);
1191
1192   generate_error (ERROR_READ_VALUE, message);
1193 }
1194
1195
1196 /* Check the current type against the saved type to make sure they are
1197    compatible.  Returns nonzero if incompatible.  */
1198
1199 static int
1200 check_type (bt type, int len)
1201 {
1202   char message[100];
1203
1204   if (saved_type != BT_NULL && saved_type != type)
1205     {
1206       st_sprintf (message, "Read type %s where %s was expected for item %d",
1207                   type_name (saved_type), type_name (type), g.item_count);
1208
1209       generate_error (ERROR_READ_VALUE, message);
1210       return 1;
1211     }
1212
1213   if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
1214     return 0;
1215
1216   if (saved_length != len)
1217     {
1218       st_sprintf (message,
1219                   "Read kind %d %s where kind %d is required for item %d",
1220                   saved_length, type_name (saved_type), len, g.item_count);
1221       generate_error (ERROR_READ_VALUE, message);
1222       return 1;
1223     }
1224
1225   return 0;
1226 }
1227
1228
1229 /* Top level data transfer subroutine for list reads.  Because we have
1230    to deal with repeat counts, the data item is always saved after
1231    reading, usually in the value[] array.  If a repeat count is
1232    greater than one, we copy the data item multiple times.  */
1233
1234 void
1235 list_formatted_read (bt type, void *p, int len)
1236 {
1237   char c;
1238   int m;
1239
1240   namelist_mode = 0;
1241
1242   if (setjmp (g.eof_jump))
1243     {
1244       generate_error (ERROR_END, NULL);
1245       return;
1246     }
1247
1248   if (g.first_item)
1249     {
1250       g.first_item = 0;
1251       input_complete = 0;
1252       repeat_count = 1;
1253       at_eol = 0;
1254
1255       c = eat_spaces ();
1256       if (is_separator (c))
1257         {                       /* Found a null value.  */
1258           eat_separator ();
1259           repeat_count = 0;
1260           if (at_eol)
1261             finish_separator ();
1262           else
1263             return;
1264         }
1265
1266     }
1267   else
1268     {
1269       if (input_complete)
1270         return;
1271
1272       if (repeat_count > 0)
1273         {
1274           if (check_type (type, len))
1275             return;
1276           goto set_value;
1277         }
1278
1279       if (at_eol)
1280         finish_separator ();
1281       else
1282         {
1283           eat_spaces ();
1284           /* trailing spaces prior to end of line */
1285           if (at_eol)
1286             finish_separator ();
1287         }
1288
1289       saved_type = BT_NULL;
1290       repeat_count = 1;
1291     }
1292
1293   switch (type)
1294     {
1295     case BT_INTEGER:
1296       read_integer (len);
1297       break;
1298     case BT_LOGICAL:
1299       read_logical (len);
1300       break;
1301     case BT_CHARACTER:
1302       read_character (len);
1303       break;
1304     case BT_REAL:
1305       read_real (len);
1306       break;
1307     case BT_COMPLEX:
1308       read_complex (len);
1309       break;
1310     default:
1311       internal_error ("Bad type for list read");
1312     }
1313
1314   if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
1315     saved_length = len;
1316
1317   if (ioparm.library_return != LIBRARY_OK)
1318     return;
1319
1320  set_value:
1321   switch (saved_type)
1322     {
1323     case BT_COMPLEX:
1324       len = 2 * len;
1325       /* Fall through.  */
1326
1327     case BT_INTEGER:
1328     case BT_REAL:
1329     case BT_LOGICAL:
1330       memcpy (p, value, len);
1331       break;
1332
1333     case BT_CHARACTER:
1334       if (saved_string)
1335        { 
1336           m = (len < saved_used) ? len : saved_used;
1337           memcpy (p, saved_string, m);
1338        }
1339       else    
1340         /* Just delimiters encountered, nothing to copy but SPACE.  */
1341         m = 0;
1342
1343       if (m < len)
1344         memset (((char *) p) + m, ' ', len - m);
1345       break;
1346
1347     case BT_NULL:
1348       break;
1349     }
1350
1351   if (--repeat_count <= 0)
1352     free_saved ();
1353 }
1354
1355 void
1356 init_at_eol(void)
1357 {
1358   at_eol = 0;
1359 }
1360
1361 /* Finish a list read.  */
1362
1363 void
1364 finish_list_read (void)
1365 {
1366   char c;
1367
1368   free_saved ();
1369
1370   if (at_eol)
1371     {
1372       at_eol = 0;
1373       return;
1374     }
1375
1376   do
1377     {
1378       c = next_char ();
1379     }
1380   while (c != '\n');
1381 }
1382
1383 static namelist_info *
1384 find_nml_node (char * var_name)
1385 {
1386    namelist_info * t = ionml;
1387    while (t != NULL)
1388      {
1389        if (strcmp (var_name,t->var_name) == 0)
1390          {
1391            t->value_acquired = 1;
1392            return t;
1393          }
1394        t = t->next;
1395      }
1396   return NULL;
1397 }
1398
1399 static void
1400 match_namelist_name (char *name, int len)
1401 {
1402   int name_len;
1403   char c;
1404   char * namelist_name = name;
1405
1406   name_len = 0;
1407   /* Match the name of the namelist.  */
1408
1409   if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
1410     {
1411     wrong_name:
1412       generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
1413       return;
1414     }
1415
1416   while (name_len < len)
1417     {
1418       c = next_char ();
1419       if (tolower (c) != tolower (namelist_name[name_len++]))
1420         goto wrong_name;
1421     }
1422 }
1423
1424
1425 /********************************************************************
1426       Namelist reads
1427 ********************************************************************/
1428
1429 /* Process a namelist read.  This subroutine initializes things,
1430    positions to the first element and 
1431    FIXME: was this comment ever complete?  */
1432
1433 void
1434 namelist_read (void)
1435 {
1436   char c;
1437   int name_matched, next_name ;
1438   namelist_info * nl;
1439   int len, m;
1440   void * p;
1441
1442   namelist_mode = 1;
1443
1444   if (setjmp (g.eof_jump))
1445     {
1446       generate_error (ERROR_END, NULL);
1447       return;
1448     }
1449
1450  restart:
1451   c = next_char ();
1452   switch (c)
1453     {
1454     case ' ':
1455       goto restart;
1456     case '!':
1457       do
1458         c = next_char ();
1459       while (c != '\n');
1460
1461       goto restart;
1462
1463     case '&':
1464       break;
1465
1466     default:
1467       generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
1468       return;
1469     }
1470
1471   /* Match the name of the namelist.  */
1472   match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
1473
1474   /* Ready to read namelist elements.  */
1475   while (!input_complete)
1476     {
1477       c = next_char ();
1478       switch (c)
1479         {
1480         case '/':
1481           input_complete = 1;
1482           next_record (0);
1483           break;
1484         case '&':
1485           match_namelist_name("end",3);
1486           return;
1487         case '\\':
1488           return;
1489         case ' ':
1490         case '\n':
1491        case '\r':
1492         case '\t':
1493           break;
1494         case ',':
1495           next_name = 1;
1496           break;
1497
1498         case '=':
1499           name_matched = 1;
1500           nl = find_nml_node (saved_string);
1501           if (nl == NULL)
1502             internal_error ("Can not match a namelist variable");
1503           free_saved();
1504
1505           len = nl->len;
1506           p = nl->mem_pos;
1507
1508           /* skip any blanks or tabs after the = */
1509           eat_spaces ();
1510  
1511           switch (nl->type)
1512             {
1513             case BT_INTEGER:
1514               read_integer (len);
1515               break;
1516             case BT_LOGICAL:
1517               read_logical (len);
1518               break;
1519             case BT_CHARACTER:
1520               read_character (len);
1521               break;
1522             case BT_REAL:
1523               read_real (len);
1524               break;
1525             case BT_COMPLEX:
1526               read_complex (len);
1527               break;
1528             default:
1529               internal_error ("Bad type for namelist read");
1530             }
1531
1532            switch (saved_type)
1533             {
1534             case BT_COMPLEX:
1535               len = 2 * len;
1536               /* Fall through...  */
1537
1538             case BT_INTEGER:
1539             case BT_REAL:
1540             case BT_LOGICAL:
1541               memcpy (p, value, len);
1542               break;
1543
1544             case BT_CHARACTER:
1545               m = (len < saved_used) ? len : saved_used;
1546               memcpy (p, saved_string, m);
1547
1548               if (m < len)
1549                 memset (((char *) p) + m, ' ', len - m);
1550               break;
1551
1552             case BT_NULL:
1553               break;
1554             }
1555
1556           break;
1557
1558         default :
1559           push_char(tolower(c));
1560           break;
1561         }
1562    }
1563 }