* cselib.c (clear_table): Rename to cselib_clear_table.
[official-gcc.git] / libgfortran / io / list_read.c
blob384df36f6c42f16d384956d444ac238f7a2f97bf
1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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.
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.)
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.
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. */
31 #include "config.h"
32 #include <string.h>
33 #include <ctype.h>
34 #include "libgfortran.h"
35 #include "io.h"
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. */
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. */
53 static int repeat_count, saved_length, saved_used, input_complete, at_eol;
54 static int comma_flag, namelist_mode;
56 static char last_char, *saved_string;
57 static bt saved_type;
61 /* Storage area for values except for strings. Must be large enough
62 to hold a complex value (two reals) of the largest kind. */
64 static char value[20];
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'
69 #define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
70 case '\r'
72 /* This macro assumes that we're operating on a variable. */
74 #define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
75 || c == '\t' || c == '\r')
77 /* Maximum repeat count. Less than ten times the maximum signed int32. */
79 #define MAX_REPEAT 200000000
82 /* Save a character to a string buffer, enlarging it as necessary. */
84 static void
85 push_char (char c)
87 char *new;
89 if (saved_string == NULL)
91 saved_string = scratch;
92 memset (saved_string,0,SCRATCH_SIZE);
93 saved_length = SCRATCH_SIZE;
94 saved_used = 0;
97 if (saved_used >= saved_length)
99 saved_length = 2 * saved_length;
100 new = get_mem (2 * saved_length);
102 memset (new,0,2 * saved_length);
104 memcpy (new, saved_string, saved_used);
105 if (saved_string != scratch)
106 free_mem (saved_string);
108 saved_string = new;
111 saved_string[saved_used++] = c;
115 /* Free the input buffer if necessary. */
117 static void
118 free_saved (void)
120 if (saved_string == NULL)
121 return;
123 if (saved_string != scratch)
124 free_mem (saved_string);
126 saved_string = NULL;
130 static char
131 next_char (void)
133 int length;
134 char c, *p;
136 if (last_char != '\0')
138 at_eol = 0;
139 c = last_char;
140 last_char = '\0';
141 goto done;
144 length = 1;
146 p = salloc_r (current_unit->s, &length);
147 if (p == NULL)
149 generate_error (ERROR_OS, NULL);
150 return '\0';
153 if (length == 0)
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);
163 else
164 c = *p;
166 done:
167 at_eol = (c == '\n' || c == '\r');
168 return c;
172 /* Push a character back onto the input. */
174 static void
175 unget_char (char c)
177 last_char = c;
181 /* Skip over spaces in the input. Returns the nonspace character that
182 terminated the eating and also places it back on the input. */
184 static char
185 eat_spaces (void)
187 char c;
191 c = next_char ();
193 while (c == ' ' || c == '\t');
195 unget_char (c);
196 return c;
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.
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. */
211 static void
212 eat_separator (void)
214 char c;
216 eat_spaces ();
217 comma_flag = 0;
219 c = next_char ();
220 switch (c)
222 case ',':
223 comma_flag = 1;
224 eat_spaces ();
225 break;
227 case '/':
228 input_complete = 1;
229 next_record (0);
230 at_eol = 1;
231 break;
233 case '\n':
234 case '\r':
235 break;
237 case '!':
238 if (namelist_mode)
239 { /* Eat a namelist comment. */
241 c = next_char ();
242 while (c != '\n');
244 break;
247 /* Fall Through... */
249 default:
250 unget_char (c);
251 break;
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. */
260 static void
261 finish_separator (void)
263 char c;
265 restart:
266 eat_spaces ();
268 c = next_char ();
269 switch (c)
271 case ',':
272 if (comma_flag)
273 unget_char (c);
274 else
276 c = eat_spaces ();
277 if (c == '\n')
278 goto restart;
281 break;
283 case '/':
284 input_complete = 1;
285 next_record (0);
286 break;
288 case '\n':
289 case '\r':
290 goto restart;
292 case '!':
293 if (namelist_mode)
296 c = next_char ();
297 while (c != '\n');
299 goto restart;
302 default:
303 unget_char (c);
304 break;
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. */
313 static int
314 convert_integer (int length, int negative)
316 char c, *buffer, message[100];
317 int m;
318 int64_t v, max, max10;
320 buffer = saved_string;
321 v = 0;
323 max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
324 max10 = max / 10;
326 for (;;)
328 c = *buffer++;
329 if (c == '\0')
330 break;
331 c -= '0';
333 if (v > max10)
334 goto overflow;
335 v = 10 * v;
337 if (v > max - c)
338 goto overflow;
339 v += c;
342 m = 0;
344 if (length != -1)
346 if (negative)
347 v = -v;
348 set_integer (value, v, length);
350 else
352 repeat_count = v;
354 if (repeat_count == 0)
356 st_sprintf (message, "Zero repeat count in item %d of list input",
357 g.item_count);
359 generate_error (ERROR_READ_VALUE, message);
360 m = 1;
364 free_saved ();
365 return m;
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);
375 free_saved ();
376 generate_error (ERROR_READ_VALUE, message);
378 return 1;
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. */
386 static int
387 parse_repeat (void)
389 char c, message[100];
390 int repeat;
392 c = next_char ();
393 switch (c)
395 CASE_DIGITS:
396 repeat = c - '0';
397 break;
399 CASE_SEPARATORS:
400 unget_char (c);
401 eat_separator ();
402 return 1;
404 default:
405 unget_char (c);
406 return 0;
409 for (;;)
411 c = next_char ();
412 switch (c)
414 CASE_DIGITS:
415 repeat = 10 * repeat + c - '0';
417 if (repeat > MAX_REPEAT)
419 st_sprintf (message,
420 "Repeat count overflow in item %d of list input",
421 g.item_count);
423 generate_error (ERROR_READ_VALUE, message);
424 return 1;
427 break;
429 case '*':
430 if (repeat == 0)
432 st_sprintf (message,
433 "Zero repeat count in item %d of list input",
434 g.item_count);
436 generate_error (ERROR_READ_VALUE, message);
437 return 1;
440 goto done;
442 default:
443 goto bad_repeat;
447 done:
448 repeat_count = repeat;
449 return 0;
451 bad_repeat:
452 st_sprintf (message, "Bad repeat count in item %d of list input",
453 g.item_count);
455 generate_error (ERROR_READ_VALUE, message);
456 return 1;
460 /* Read a logical character on the input. */
462 static void
463 read_logical (int length)
465 char c, message[100];
466 int v;
468 if (parse_repeat ())
469 return;
471 c = next_char ();
472 switch (c)
474 case 't':
475 case 'T':
476 v = 1;
477 break;
478 case 'f':
479 case 'F':
480 v = 0;
481 break;
483 case '.':
484 c = next_char ();
485 switch (c)
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;
499 break;
501 CASE_SEPARATORS:
502 unget_char (c);
503 eat_separator ();
504 return; /* Null value. */
506 default:
507 goto bad_logical;
510 saved_type = BT_LOGICAL;
511 saved_length = length;
513 /* Eat trailing garbage. */
516 c = next_char ();
518 while (!is_separator (c));
520 unget_char (c);
521 eat_separator ();
522 free_saved ();
523 set_integer ((int *) value, v, length);
525 return;
527 bad_logical:
528 st_sprintf (message, "Bad logical value while reading item %d",
529 g.item_count);
531 generate_error (ERROR_READ_VALUE, message);
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. */
540 static void
541 read_integer (int length)
543 char c, message[100];
544 int negative;
546 negative = 0;
548 c = next_char ();
549 switch (c)
551 case '-':
552 negative = 1;
553 /* Fall through... */
555 case '+':
556 c = next_char ();
557 goto get_integer;
559 CASE_SEPARATORS: /* Single null. */
560 unget_char (c);
561 eat_separator ();
562 return;
564 CASE_DIGITS:
565 push_char (c);
566 break;
568 default:
569 goto bad_integer;
572 /* Take care of what may be a repeat count. */
574 for (;;)
576 c = next_char ();
577 switch (c)
579 CASE_DIGITS:
580 push_char (c);
581 break;
583 case '*':
584 push_char ('\0');
585 goto repeat;
587 CASE_SEPARATORS: /* Not a repeat count. */
588 goto done;
590 default:
591 goto bad_integer;
595 repeat:
596 if (convert_integer (-1, 0))
597 return;
599 /* Get the real integer. */
601 c = next_char ();
602 switch (c)
604 CASE_DIGITS:
605 break;
607 CASE_SEPARATORS:
608 unget_char (c);
609 eat_separator ();
610 return;
612 case '-':
613 negative = 1;
614 /* Fall through... */
616 case '+':
617 c = next_char ();
618 break;
621 get_integer:
622 if (!isdigit (c))
623 goto bad_integer;
624 push_char (c);
626 for (;;)
628 c = next_char ();
629 switch (c)
631 CASE_DIGITS:
632 push_char (c);
633 break;
635 CASE_SEPARATORS:
636 goto done;
638 default:
639 goto bad_integer;
643 bad_integer:
644 free_saved ();
646 st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
647 generate_error (ERROR_READ_VALUE, message);
649 return;
651 done:
652 unget_char (c);
653 eat_separator ();
655 push_char ('\0');
656 if (convert_integer (length, negative))
658 free_saved ();
659 return;
662 free_saved ();
663 saved_type = BT_INTEGER;
667 /* Read a character variable. */
669 static void
670 read_character (int length)
672 char c, quote, message[100];
674 quote = ' '; /* Space means no quote character. */
676 c = next_char ();
677 switch (c)
679 CASE_DIGITS:
680 push_char (c);
681 break;
683 CASE_SEPARATORS:
684 unget_char (c); /* NULL value. */
685 eat_separator ();
686 return;
688 case '"':
689 case '\'':
690 quote = c;
691 goto get_string;
693 default:
694 push_char (c);
695 goto get_string;
698 /* Deal with a possible repeat count. */
700 for (;;)
702 c = next_char ();
703 switch (c)
705 CASE_DIGITS:
706 push_char (c);
707 break;
709 CASE_SEPARATORS:
710 unget_char (c);
711 goto done; /* String was only digits! */
713 case '*':
714 push_char ('\0');
715 goto got_repeat;
717 default:
718 push_char (c);
719 goto get_string; /* Not a repeat count after all. */
723 got_repeat:
724 if (convert_integer (-1, 0))
725 return;
727 /* Now get the real string. */
729 c = next_char ();
730 switch (c)
732 CASE_SEPARATORS:
733 unget_char (c); /* Repeated NULL values. */
734 eat_separator ();
735 return;
737 case '"':
738 case '\'':
739 quote = c;
740 break;
742 default:
743 push_char (c);
744 break;
747 get_string:
748 for (;;)
750 c = next_char ();
751 switch (c)
753 case '"':
754 case '\'':
755 if (c != quote)
757 push_char (c);
758 break;
761 /* See if we have a doubled quote character or the end of
762 the string. */
764 c = next_char ();
765 if (c == quote)
767 push_char (quote);
768 break;
771 unget_char (c);
772 goto done;
774 CASE_SEPARATORS:
775 if (quote == ' ')
777 unget_char (c);
778 goto done;
781 if (c != '\n')
782 push_char (c);
783 break;
785 default:
786 push_char (c);
787 break;
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))
797 unget_char (c);
798 eat_separator ();
799 saved_type = BT_CHARACTER;
801 else
803 free_saved ();
804 st_sprintf (message, "Invalid string input in item %d", g.item_count);
805 generate_error (ERROR_READ_VALUE, message);
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. */
813 static int
814 parse_real (void *buffer, int length)
816 char c, message[100];
817 int m, seen_dp;
819 c = next_char ();
820 if (c == '-' || c == '+')
822 push_char (c);
823 c = next_char ();
826 if (!isdigit (c) && c != '.')
827 goto bad;
829 push_char (c);
831 seen_dp = (c == '.') ? 1 : 0;
833 for (;;)
835 c = next_char ();
836 switch (c)
838 CASE_DIGITS:
839 push_char (c);
840 break;
842 case '.':
843 if (seen_dp)
844 goto bad;
846 seen_dp = 1;
847 push_char (c);
848 break;
850 case 'e':
851 case 'E':
852 case 'd':
853 case 'D':
854 push_char ('e');
855 goto exp1;
857 case '-':
858 case '+':
859 push_char ('e');
860 push_char (c);
861 c = next_char ();
862 goto exp2;
864 CASE_SEPARATORS:
865 unget_char (c);
866 goto done;
868 default:
869 goto done;
873 exp1:
874 c = next_char ();
875 if (c != '-' && c != '+')
876 push_char ('+');
877 else
879 push_char (c);
880 c = next_char ();
883 exp2:
884 if (!isdigit (c))
885 goto bad;
886 push_char (c);
888 for (;;)
890 c = next_char ();
891 switch (c)
893 CASE_DIGITS:
894 push_char (c);
895 break;
897 CASE_SEPARATORS:
898 unget_char (c);
899 goto done;
901 default:
902 goto done;
906 done:
907 unget_char (c);
908 push_char ('\0');
910 m = convert_real (buffer, saved_string, length);
911 free_saved ();
913 return m;
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);
920 return 1;
924 /* Reading a complex number is straightforward because we can tell
925 what it is right away. */
927 static void
928 read_complex (int length)
930 char message[100];
931 char c;
933 if (parse_repeat ())
934 return;
936 c = next_char ();
937 switch (c)
939 case '(':
940 break;
942 CASE_SEPARATORS:
943 unget_char (c);
944 eat_separator ();
945 return;
947 default:
948 goto bad_complex;
951 eat_spaces ();
952 if (parse_real (value, length))
953 return;
955 eat_spaces ();
956 if (next_char () != ',')
957 goto bad_complex;
959 eat_spaces ();
960 if (parse_real (value + length, length))
961 return;
963 eat_spaces ();
964 if (next_char () != ')')
965 goto bad_complex;
967 c = next_char ();
968 if (!is_separator (c))
969 goto bad_complex;
971 unget_char (c);
972 eat_separator ();
974 free_saved ();
975 saved_type = BT_COMPLEX;
976 return;
978 bad_complex:
979 st_sprintf (message, "Bad complex value in item %d of list input",
980 g.item_count);
982 generate_error (ERROR_READ_VALUE, message);
986 /* Parse a real number with a possible repeat count. */
988 static void
989 read_real (int length)
991 char c, message[100];
992 int seen_dp;
994 seen_dp = 0;
996 c = next_char ();
997 switch (c)
999 CASE_DIGITS:
1000 push_char (c);
1001 break;
1003 case '.':
1004 push_char (c);
1005 seen_dp = 1;
1006 break;
1008 case '+':
1009 case '-':
1010 goto got_sign;
1012 CASE_SEPARATORS:
1013 unget_char (c); /* Single null. */
1014 eat_separator ();
1015 return;
1017 default:
1018 goto bad_real;
1021 /* Get the digit string that might be a repeat count. */
1023 for (;;)
1025 c = next_char ();
1026 switch (c)
1028 CASE_DIGITS:
1029 push_char (c);
1030 break;
1032 case '.':
1033 if (seen_dp)
1034 goto bad_real;
1036 seen_dp = 1;
1037 push_char (c);
1038 goto real_loop;
1040 case 'E':
1041 case 'e':
1042 case 'D':
1043 case 'd':
1044 goto exp1;
1046 case '+':
1047 case '-':
1048 push_char ('e');
1049 push_char (c);
1050 c = next_char ();
1051 goto exp2;
1053 case '*':
1054 push_char ('\0');
1055 goto got_repeat;
1057 CASE_SEPARATORS:
1058 if (c != '\n' && c != ',' && c != '\r')
1059 unget_char (c);
1060 goto done;
1062 default:
1063 goto bad_real;
1067 got_repeat:
1068 if (convert_integer (-1, 0))
1069 return;
1071 /* Now get the number itself. */
1073 c = next_char ();
1074 if (is_separator (c))
1075 { /* Repeated null value. */
1076 unget_char (c);
1077 eat_separator ();
1078 return;
1081 if (c != '-' && c != '+')
1082 push_char ('+');
1083 else
1085 got_sign:
1086 push_char (c);
1087 c = next_char ();
1090 if (!isdigit (c) && c != '.')
1091 goto bad_real;
1093 if (c == '.')
1095 if (seen_dp)
1096 goto bad_real;
1097 else
1098 seen_dp = 1;
1101 push_char (c);
1103 real_loop:
1104 for (;;)
1106 c = next_char ();
1107 switch (c)
1109 CASE_DIGITS:
1110 push_char (c);
1111 break;
1113 CASE_SEPARATORS:
1114 goto done;
1116 case '.':
1117 if (seen_dp)
1118 goto bad_real;
1120 seen_dp = 1;
1121 push_char (c);
1122 break;
1124 case 'E':
1125 case 'e':
1126 case 'D':
1127 case 'd':
1128 goto exp1;
1130 case '+':
1131 case '-':
1132 push_char ('e');
1133 push_char (c);
1134 c = next_char ();
1135 goto exp2;
1137 default:
1138 goto bad_real;
1142 exp1:
1143 push_char ('e');
1145 c = next_char ();
1146 if (c != '+' && c != '-')
1147 push_char ('+');
1148 else
1150 push_char (c);
1151 c = next_char ();
1154 exp2:
1155 if (!isdigit (c))
1156 goto bad_real;
1157 push_char (c);
1159 for (;;)
1161 c = next_char ();
1163 switch (c)
1165 CASE_DIGITS:
1166 push_char (c);
1167 break;
1169 CASE_SEPARATORS:
1170 goto done;
1172 default:
1173 goto bad_real;
1177 done:
1178 unget_char (c);
1179 eat_separator ();
1180 push_char ('\0');
1181 if (convert_real (value, saved_string, length))
1182 return;
1184 free_saved ();
1185 saved_type = BT_REAL;
1186 return;
1188 bad_real:
1189 st_sprintf (message, "Bad real number in item %d of list input",
1190 g.item_count);
1192 generate_error (ERROR_READ_VALUE, message);
1196 /* Check the current type against the saved type to make sure they are
1197 compatible. Returns nonzero if incompatible. */
1199 static int
1200 check_type (bt type, int len)
1202 char message[100];
1204 if (saved_type != BT_NULL && saved_type != type)
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);
1209 generate_error (ERROR_READ_VALUE, message);
1210 return 1;
1213 if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
1214 return 0;
1216 if (saved_length != len)
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;
1225 return 0;
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. */
1234 void
1235 list_formatted_read (bt type, void *p, int len)
1237 char c;
1238 int m;
1240 namelist_mode = 0;
1242 if (setjmp (g.eof_jump))
1244 generate_error (ERROR_END, NULL);
1245 return;
1248 if (g.first_item)
1250 g.first_item = 0;
1251 input_complete = 0;
1252 repeat_count = 1;
1253 at_eol = 0;
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;
1267 else
1269 if (input_complete)
1270 return;
1272 if (repeat_count > 0)
1274 if (check_type (type, len))
1275 return;
1276 goto set_value;
1279 if (at_eol)
1280 finish_separator ();
1281 else
1283 eat_spaces ();
1284 /* trailing spaces prior to end of line */
1285 if (at_eol)
1286 finish_separator ();
1289 saved_type = BT_NULL;
1290 repeat_count = 1;
1293 switch (type)
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");
1314 if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
1315 saved_length = len;
1317 if (ioparm.library_return != LIBRARY_OK)
1318 return;
1320 set_value:
1321 switch (saved_type)
1323 case BT_COMPLEX:
1324 len = 2 * len;
1325 /* Fall through. */
1327 case BT_INTEGER:
1328 case BT_REAL:
1329 case BT_LOGICAL:
1330 memcpy (p, value, len);
1331 break;
1333 case BT_CHARACTER:
1334 if (saved_string)
1336 m = (len < saved_used) ? len : saved_used;
1337 memcpy (p, saved_string, m);
1339 else
1340 /* Just delimiters encountered, nothing to copy but SPACE. */
1341 m = 0;
1343 if (m < len)
1344 memset (((char *) p) + m, ' ', len - m);
1345 break;
1347 case BT_NULL:
1348 break;
1351 if (--repeat_count <= 0)
1352 free_saved ();
1355 void
1356 init_at_eol(void)
1358 at_eol = 0;
1361 /* Finish a list read. */
1363 void
1364 finish_list_read (void)
1366 char c;
1368 free_saved ();
1370 if (at_eol)
1372 at_eol = 0;
1373 return;
1378 c = next_char ();
1380 while (c != '\n');
1383 static namelist_info *
1384 find_nml_node (char * var_name)
1386 namelist_info * t = ionml;
1387 while (t != NULL)
1389 if (strcmp (var_name,t->var_name) == 0)
1391 t->value_acquired = 1;
1392 return t;
1394 t = t->next;
1396 return NULL;
1399 static void
1400 match_namelist_name (char *name, int len)
1402 int name_len;
1403 char c;
1404 char * namelist_name = name;
1406 name_len = 0;
1407 /* Match the name of the namelist. */
1409 if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
1411 wrong_name:
1412 generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
1413 return;
1416 while (name_len < len)
1418 c = next_char ();
1419 if (tolower (c) != tolower (namelist_name[name_len++]))
1420 goto wrong_name;
1425 /********************************************************************
1426 Namelist reads
1427 ********************************************************************/
1429 /* Process a namelist read. This subroutine initializes things,
1430 positions to the first element and
1431 FIXME: was this comment ever complete? */
1433 void
1434 namelist_read (void)
1436 char c;
1437 int name_matched, next_name ;
1438 namelist_info * nl;
1439 int len, m;
1440 void * p;
1442 namelist_mode = 1;
1444 if (setjmp (g.eof_jump))
1446 generate_error (ERROR_END, NULL);
1447 return;
1450 restart:
1451 c = next_char ();
1452 switch (c)
1454 case ' ':
1455 goto restart;
1456 case '!':
1458 c = next_char ();
1459 while (c != '\n');
1461 goto restart;
1463 case '&':
1464 break;
1466 default:
1467 generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
1468 return;
1471 /* Match the name of the namelist. */
1472 match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
1474 /* Ready to read namelist elements. */
1475 while (!input_complete)
1477 c = next_char ();
1478 switch (c)
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;
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();
1505 len = nl->len;
1506 p = nl->mem_pos;
1508 /* skip any blanks or tabs after the = */
1509 eat_spaces ();
1511 switch (nl->type)
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");
1532 switch (saved_type)
1534 case BT_COMPLEX:
1535 len = 2 * len;
1536 /* Fall through... */
1538 case BT_INTEGER:
1539 case BT_REAL:
1540 case BT_LOGICAL:
1541 memcpy (p, value, len);
1542 break;
1544 case BT_CHARACTER:
1545 m = (len < saved_used) ? len : saved_used;
1546 memcpy (p, saved_string, m);
1548 if (m < len)
1549 memset (((char *) p) + m, ' ', len - m);
1550 break;
1552 case BT_NULL:
1553 break;
1556 break;
1558 default :
1559 push_char(tolower(c));
1560 break;