merge from 1.8 branch
[bpt/guile.git] / libguile / read.c
1 /* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006 Free Software
2 * Foundation, Inc.
3 *
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
8 *
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
13 *
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17 */
18
19
20 \f
21
22 #include <stdio.h>
23 #include "libguile/_scm.h"
24 #include "libguile/chars.h"
25 #include "libguile/eval.h"
26 #include "libguile/unif.h"
27 #include "libguile/keywords.h"
28 #include "libguile/alist.h"
29 #include "libguile/srcprop.h"
30 #include "libguile/hashtab.h"
31 #include "libguile/hash.h"
32 #include "libguile/ports.h"
33 #include "libguile/root.h"
34 #include "libguile/strings.h"
35 #include "libguile/strports.h"
36 #include "libguile/vectors.h"
37 #include "libguile/validate.h"
38 #include "libguile/srfi-4.h"
39
40 #include "libguile/read.h"
41
42 \f
43
44 SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
45 SCM_SYMBOL (scm_keyword_prefix, "prefix");
46
47 scm_t_option scm_read_opts[] = {
48 { SCM_OPTION_BOOLEAN, "copy", 0,
49 "Copy source code expressions." },
50 { SCM_OPTION_BOOLEAN, "positions", 0,
51 "Record positions of source code expressions." },
52 { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
53 "Convert symbols to lower case."},
54 { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
55 "Style of keyword recognition: #f or 'prefix."}
56 #if SCM_ENABLE_ELISP
57 ,
58 { SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
59 "Support Elisp vector syntax, namely `[...]'."},
60 { SCM_OPTION_BOOLEAN, "elisp-strings", 0,
61 "Support `\\(' and `\\)' in strings."}
62 #endif
63 };
64
65 /*
66 Give meaningful error messages for errors
67
68 We use the format
69
70 FILE:LINE:COL: MESSAGE
71 This happened in ....
72
73 This is not standard GNU format, but the test-suite likes the real
74 message to be in front.
75
76 */
77
78
79 void
80 scm_i_input_error (char const *function,
81 SCM port, const char *message, SCM arg)
82 {
83 SCM fn = (scm_is_string (SCM_FILENAME(port))
84 ? SCM_FILENAME(port)
85 : scm_from_locale_string ("#<unknown port>"));
86
87 SCM string_port = scm_open_output_string ();
88 SCM string = SCM_EOL;
89 scm_simple_format (string_port,
90 scm_from_locale_string ("~A:~S:~S: ~A"),
91 scm_list_4 (fn,
92 scm_from_int (SCM_LINUM (port) + 1),
93 scm_from_int (SCM_COL (port) + 1),
94 scm_from_locale_string (message)));
95
96 string = scm_get_output_string (string_port);
97 scm_close_output_port (string_port);
98 scm_error_scm (scm_from_locale_symbol ("read-error"),
99 function? scm_from_locale_string (function) : SCM_BOOL_F,
100 string,
101 arg,
102 SCM_BOOL_F);
103 }
104
105
106 SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
107 (SCM setting),
108 "Option interface for the read options. Instead of using\n"
109 "this procedure directly, use the procedures @code{read-enable},\n"
110 "@code{read-disable}, @code{read-set!} and @code{read-options}.")
111 #define FUNC_NAME s_scm_read_options
112 {
113 SCM ans = scm_options (setting,
114 scm_read_opts,
115 SCM_N_READ_OPTIONS,
116 FUNC_NAME);
117 if (SCM_COPY_SOURCE_P)
118 SCM_RECORD_POSITIONS_P = 1;
119 return ans;
120 }
121 #undef FUNC_NAME
122
123 /* An association list mapping extra hash characters to procedures. */
124 static SCM *scm_read_hash_procedures;
125
126 SCM_DEFINE (scm_read, "read", 0, 1, 0,
127 (SCM port),
128 "Read an s-expression from the input port @var{port}, or from\n"
129 "the current input port if @var{port} is not specified.\n"
130 "Any whitespace before the next token is discarded.")
131 #define FUNC_NAME s_scm_read
132 {
133 int c;
134 SCM tok_buf, copy;
135
136 if (SCM_UNBNDP (port))
137 port = scm_current_input_port ();
138 SCM_VALIDATE_OPINPORT (1, port);
139
140 c = scm_flush_ws (port, (char *) NULL);
141 if (EOF == c)
142 return SCM_EOF_VAL;
143 scm_ungetc (c, port);
144
145 tok_buf = scm_c_make_string (30, SCM_UNDEFINED);
146 return scm_lreadr (&tok_buf, port, &copy);
147 }
148 #undef FUNC_NAME
149
150
151
152 char *
153 scm_grow_tok_buf (SCM *tok_buf)
154 {
155 size_t oldlen = scm_i_string_length (*tok_buf);
156 const char *olddata = scm_i_string_chars (*tok_buf);
157 char *newdata;
158 SCM newstr = scm_i_make_string (2 * oldlen, &newdata);
159 size_t i;
160
161 for (i = 0; i != oldlen; ++i)
162 newdata[i] = olddata[i];
163
164 *tok_buf = newstr;
165 return newdata;
166 }
167
168 /* Consume an SCSH-style block comment. Assume that we've already
169 read the initial `#!', and eat characters until we get a
170 exclamation-point/sharp-sign sequence.
171 */
172
173 static void
174 skip_scsh_block_comment (SCM port)
175 {
176 int bang_seen = 0;
177
178 for (;;)
179 {
180 int c = scm_getc (port);
181
182 if (c == EOF)
183 scm_i_input_error ("skip_block_comment", port,
184 "unterminated `#! ... !#' comment", SCM_EOL);
185
186 if (c == '!')
187 bang_seen = 1;
188 else if (c == '#' && bang_seen)
189 return;
190 else
191 bang_seen = 0;
192 }
193 }
194
195 int
196 scm_flush_ws (SCM port, const char *eoferr)
197 {
198 register int c;
199 while (1)
200 switch (c = scm_getc (port))
201 {
202 case EOF:
203 goteof:
204 if (eoferr)
205 {
206 scm_i_input_error (eoferr,
207 port,
208 "end of file",
209 SCM_EOL);
210 }
211 return c;
212 case ';':
213 lp:
214 switch (c = scm_getc (port))
215 {
216 case EOF:
217 goto goteof;
218 default:
219 goto lp;
220 case SCM_LINE_INCREMENTORS:
221 break;
222 }
223 break;
224 case '#':
225 switch (c = scm_getc (port))
226 {
227 case EOF:
228 eoferr = "read_sharp";
229 goto goteof;
230 case '!':
231 skip_scsh_block_comment (port);
232 break;
233 default:
234 scm_ungetc (c, port);
235 return '#';
236 }
237 break;
238 case SCM_LINE_INCREMENTORS:
239 case SCM_SINGLE_SPACES:
240 case '\t':
241 break;
242 default:
243 return c;
244 }
245 }
246
247
248
249 int
250 scm_casei_streq (char *s1, char *s2)
251 {
252 while (*s1 && *s2)
253 if (scm_c_downcase((int)*s1) != scm_c_downcase((int)*s2))
254 return 0;
255 else
256 {
257 ++s1;
258 ++s2;
259 }
260 return !(*s1 || *s2);
261 }
262
263 static int
264 scm_i_casei_streq (const char *s1, const char *s2, size_t len2)
265 {
266 while (*s1 && len2 > 0)
267 if (scm_c_downcase((int)*s1) != scm_c_downcase((int)*s2))
268 return 0;
269 else
270 {
271 ++s1;
272 ++s2;
273 --len2;
274 }
275 return !(*s1 || len2 > 0);
276 }
277
278 /* recsexpr is used when recording expressions
279 * constructed by read:sharp.
280 */
281 static SCM
282 recsexpr (SCM obj, long line, int column, SCM filename)
283 {
284 if (!scm_is_pair(obj)) {
285 return obj;
286 } else {
287 SCM tmp = obj, copy;
288 /* If this sexpr is visible in the read:sharp source, we want to
289 keep that information, so only record non-constant cons cells
290 which haven't previously been read by the reader. */
291 if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
292 {
293 if (SCM_COPY_SOURCE_P)
294 {
295 copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
296 SCM_UNDEFINED);
297 while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
298 {
299 SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
300 line,
301 column,
302 filename),
303 SCM_UNDEFINED));
304 copy = SCM_CDR (copy);
305 }
306 SCM_SETCDR (copy, tmp);
307 }
308 else
309 {
310 recsexpr (SCM_CAR (obj), line, column, filename);
311 while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
312 recsexpr (SCM_CAR (tmp), line, column, filename);
313 copy = SCM_UNDEFINED;
314 }
315 scm_whash_insert (scm_source_whash,
316 obj,
317 scm_make_srcprops (line,
318 column,
319 filename,
320 copy,
321 SCM_EOL));
322 }
323 return obj;
324 }
325 }
326
327
328 static SCM scm_get_hash_procedure(int c);
329 static SCM scm_i_lreadparen (SCM *, SCM, char *, SCM *, char);
330
331 static char s_list[]="list";
332 static char s_vector[]="vector";
333
334 SCM
335 scm_lreadr (SCM *tok_buf, SCM port, SCM *copy)
336 #define FUNC_NAME "scm_lreadr"
337 {
338 int c;
339 size_t j;
340 SCM p;
341
342 tryagain:
343 c = scm_flush_ws (port, s_scm_read);
344 switch (c)
345 {
346 case EOF:
347 return SCM_EOF_VAL;
348
349 case '(':
350 return SCM_RECORD_POSITIONS_P
351 ? scm_lreadrecparen (tok_buf, port, s_list, copy)
352 : scm_i_lreadparen (tok_buf, port, s_list, copy, ')');
353 case ')':
354 scm_i_input_error (FUNC_NAME, port,"unexpected \")\"", SCM_EOL);
355 goto tryagain;
356
357 #if SCM_ENABLE_ELISP
358 case '[':
359 if (SCM_ELISP_VECTORS_P)
360 {
361 p = scm_i_lreadparen (tok_buf, port, s_vector, copy, ']');
362 return scm_is_null (p) ? scm_nullvect : scm_vector (p);
363 }
364 goto read_token;
365 #endif
366 case '\'':
367 p = scm_sym_quote;
368 goto recquote;
369 case '`':
370 p = scm_sym_quasiquote;
371 goto recquote;
372 case ',':
373 c = scm_getc (port);
374 if ('@' == c)
375 p = scm_sym_uq_splicing;
376 else
377 {
378 scm_ungetc (c, port);
379 p = scm_sym_unquote;
380 }
381 recquote:
382 p = scm_cons2 (p,
383 scm_lreadr (tok_buf, port, copy),
384 SCM_EOL);
385 if (SCM_RECORD_POSITIONS_P)
386 scm_whash_insert (scm_source_whash,
387 p,
388 scm_make_srcprops (SCM_LINUM (port),
389 SCM_COL (port) - 1,
390 SCM_FILENAME (port),
391 SCM_COPY_SOURCE_P
392 ? (*copy = scm_cons2 (SCM_CAR (p),
393 SCM_CAR (SCM_CDR (p)),
394 SCM_EOL))
395 : SCM_UNDEFINED,
396 SCM_EOL));
397 return p;
398 case '#':
399 c = scm_getc (port);
400
401 {
402 /* Check for user-defined hash procedure first, to allow
403 overriding of builtin hash read syntaxes. */
404 SCM sharp = scm_get_hash_procedure (c);
405 if (scm_is_true (sharp))
406 {
407 int line = SCM_LINUM (port);
408 int column = SCM_COL (port) - 2;
409 SCM got;
410
411 got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port);
412 if (scm_is_eq (got, SCM_UNSPECIFIED))
413 goto handle_sharp;
414 if (SCM_RECORD_POSITIONS_P)
415 return *copy = recsexpr (got, line, column,
416 SCM_FILENAME (port));
417 else
418 return got;
419 }
420 }
421 handle_sharp:
422 switch (c)
423 {
424 /* Vector, arrays, both uniform and not are handled by this
425 one function. It also disambiguates between '#f' and
426 '#f32' and '#f64'.
427 */
428 case '0': case '1': case '2': case '3': case '4':
429 case '5': case '6': case '7': case '8': case '9':
430 case 'u': case 's': case 'f':
431 case '@':
432 case '(':
433 #if SCM_ENABLE_DEPRECATED
434 /* See below for 'i' and 'e'. */
435 case 'a':
436 case 'c':
437 case 'y':
438 case 'h':
439 case 'l':
440 #endif
441 return scm_i_read_array (port, c);
442
443 case 't':
444 case 'T':
445 return SCM_BOOL_T;
446
447 case 'F':
448 /* See above for lower case 'f'. */
449 return SCM_BOOL_F;
450
451
452 case 'i':
453 case 'e':
454 #if SCM_ENABLE_DEPRECATED
455 {
456 /* When next char is '(', it really is an old-style
457 uniform array. */
458 int next_c = scm_getc (port);
459 if (next_c != EOF)
460 scm_ungetc (next_c, port);
461 if (next_c == '(')
462 return scm_i_read_array (port, c);
463 /* Fall through. */
464 }
465 #endif
466 case 'b':
467 case 'B':
468 case 'o':
469 case 'O':
470 case 'd':
471 case 'D':
472 case 'x':
473 case 'X':
474 case 'I':
475 case 'E':
476 scm_ungetc (c, port);
477 c = '#';
478 goto num;
479
480 case '!':
481 /* should never happen, #!...!# block comments are skipped
482 over in scm_flush_ws. */
483 abort ();
484
485 case '*':
486 j = scm_read_token (c, tok_buf, port, 0);
487 p = scm_istr2bve (scm_c_substring_shared (*tok_buf, 1, j));
488 if (scm_is_true (p))
489 return p;
490 else
491 goto unkshrp;
492
493 case '{':
494 j = scm_read_token (c, tok_buf, port, 1);
495 return scm_string_to_symbol (scm_c_substring_copy (*tok_buf, 0, j));
496
497 case '\\':
498 c = scm_getc (port);
499 j = scm_read_token (c, tok_buf, port, 0);
500 if (j == 1)
501 return SCM_MAKE_CHAR (c);
502 if (c >= '0' && c < '8')
503 {
504 /* Dirk:FIXME:: This type of character syntax is not R5RS
505 * compliant. Further, it should be verified that the constant
506 * does only consist of octal digits. Finally, it should be
507 * checked whether the resulting fixnum is in the range of
508 * characters. */
509 p = scm_c_locale_stringn_to_number (scm_i_string_chars (*tok_buf),
510 j, 8);
511 if (SCM_I_INUMP (p))
512 return SCM_MAKE_CHAR (SCM_I_INUM (p));
513 }
514 for (c = 0; c < scm_n_charnames; c++)
515 if (scm_charnames[c]
516 && (scm_i_casei_streq (scm_charnames[c],
517 scm_i_string_chars (*tok_buf), j)))
518 return SCM_MAKE_CHAR (scm_charnums[c]);
519 scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
520 scm_list_1 (scm_c_substring (*tok_buf, 0, j)));
521
522 /* #:SYMBOL is a syntax for keywords supported in all contexts. */
523 case ':':
524 return scm_symbol_to_keyword (scm_read (port));
525
526 default:
527 callshrp:
528 {
529 SCM sharp = scm_get_hash_procedure (c);
530
531 if (scm_is_true (sharp))
532 {
533 int line = SCM_LINUM (port);
534 int column = SCM_COL (port) - 2;
535 SCM got;
536
537 got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port);
538 if (scm_is_eq (got, SCM_UNSPECIFIED))
539 goto unkshrp;
540 if (SCM_RECORD_POSITIONS_P)
541 return *copy = recsexpr (got, line, column,
542 SCM_FILENAME (port));
543 else
544 return got;
545 }
546 }
547 unkshrp:
548 scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
549 scm_list_1 (SCM_MAKE_CHAR (c)));
550 }
551
552 case '"':
553 j = 0;
554 while ('"' != (c = scm_getc (port)))
555 {
556 if (c == EOF)
557 str_eof: scm_i_input_error (FUNC_NAME, port,
558 "end of file in string constant",
559 SCM_EOL);
560
561 while (j + 2 >= scm_i_string_length (*tok_buf))
562 scm_grow_tok_buf (tok_buf);
563
564 if (c == '\\')
565 switch (c = scm_getc (port))
566 {
567 case EOF:
568 goto str_eof;
569 case '"':
570 case '\\':
571 break;
572 #if SCM_ENABLE_ELISP
573 case '(':
574 case ')':
575 if (SCM_ESCAPED_PARENS_P)
576 break;
577 goto bad_escaped;
578 #endif
579 case '\n':
580 continue;
581 case '0':
582 c = '\0';
583 break;
584 case 'f':
585 c = '\f';
586 break;
587 case 'n':
588 c = '\n';
589 break;
590 case 'r':
591 c = '\r';
592 break;
593 case 't':
594 c = '\t';
595 break;
596 case 'a':
597 c = '\007';
598 break;
599 case 'v':
600 c = '\v';
601 break;
602 case 'x':
603 {
604 int a, b;
605 a = scm_getc (port);
606 if (a == EOF) goto str_eof;
607 b = scm_getc (port);
608 if (b == EOF) goto str_eof;
609 if ('0' <= a && a <= '9') a -= '0';
610 else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
611 else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
612 else goto bad_escaped;
613 if ('0' <= b && b <= '9') b -= '0';
614 else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
615 else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
616 else goto bad_escaped;
617 c = a * 16 + b;
618 break;
619 }
620 default:
621 bad_escaped:
622 scm_i_input_error(FUNC_NAME, port,
623 "illegal character in escape sequence: ~S",
624 scm_list_1 (SCM_MAKE_CHAR (c)));
625 }
626 scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c));
627 ++j;
628 }
629 if (j == 0)
630 return scm_nullstr;
631
632 /* Change this to scm_c_substring_read_only when
633 SCM_STRING_CHARS has been removed.
634 */
635 return scm_c_substring_copy (*tok_buf, 0, j);
636
637 case '0': case '1': case '2': case '3': case '4':
638 case '5': case '6': case '7': case '8': case '9':
639 case '.':
640 case '-':
641 case '+':
642 num:
643 j = scm_read_token (c, tok_buf, port, 0);
644 if (j == 1 && (c == '+' || c == '-'))
645 /* Shortcut: Detected symbol '+ or '- */
646 goto tok;
647
648 p = scm_c_locale_stringn_to_number (scm_i_string_chars (*tok_buf), j, 10);
649 if (scm_is_true (p))
650 return p;
651 if (c == '#')
652 {
653 if ((j == 2) && (scm_getc (port) == '('))
654 {
655 scm_ungetc ('(', port);
656 c = scm_i_string_chars (*tok_buf)[1];
657 goto callshrp;
658 }
659 scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
660 }
661 goto tok;
662
663 case ':':
664 if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
665 return scm_symbol_to_keyword (scm_read (port));
666
667 /* fallthrough */
668 default:
669 #if SCM_ENABLE_ELISP
670 read_token:
671 #endif
672 j = scm_read_token (c, tok_buf, port, 0);
673 /* fallthrough */
674
675 tok:
676 return scm_string_to_symbol (scm_c_substring (*tok_buf, 0, j));
677 }
678 }
679 #undef FUNC_NAME
680
681
682 #ifdef _UNICOS
683 _Pragma ("noopt"); /* # pragma _CRI noopt */
684 #endif
685
686 size_t
687 scm_read_token (int ic, SCM *tok_buf, SCM port, int weird)
688 {
689 size_t j;
690 int c;
691
692 c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(ic) : ic);
693
694 if (weird)
695 j = 0;
696 else
697 {
698 j = 0;
699 while (j + 2 >= scm_i_string_length (*tok_buf))
700 scm_grow_tok_buf (tok_buf);
701 scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c));
702 ++j;
703 }
704
705 while (1)
706 {
707 while (j + 2 >= scm_i_string_length (*tok_buf))
708 scm_grow_tok_buf (tok_buf);
709 c = scm_getc (port);
710 switch (c)
711 {
712 case '(':
713 case ')':
714 #if SCM_ENABLE_ELISP
715 case '[':
716 case ']':
717 #endif
718 case '"':
719 case ';':
720 case SCM_WHITE_SPACES:
721 case SCM_LINE_INCREMENTORS:
722 if (weird
723 #if SCM_ENABLE_ELISP
724 || ((!SCM_ELISP_VECTORS_P) && ((c == '[') || (c == ']')))
725 #endif
726 )
727 goto default_case;
728
729 scm_ungetc (c, port);
730 case EOF:
731 eof_case:
732 return j;
733 case '\\':
734 if (!weird)
735 goto default_case;
736 else
737 {
738 c = scm_getc (port);
739 if (c == EOF)
740 goto eof_case;
741 else
742 goto default_case;
743 }
744 case '}':
745 if (!weird)
746 goto default_case;
747
748 c = scm_getc (port);
749 if (c == '#')
750 {
751 return j;
752 }
753 else
754 {
755 scm_ungetc (c, port);
756 c = '}';
757 goto default_case;
758 }
759
760 default:
761 default_case:
762 {
763 c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(c) : c);
764 scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c));
765 ++j;
766 }
767
768 }
769 }
770 }
771
772 #ifdef _UNICOS
773 _Pragma ("opt"); /* # pragma _CRI opt */
774 #endif
775
776 static SCM
777 scm_i_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy, char term_char)
778 #define FUNC_NAME "scm_i_lreadparen"
779 {
780 SCM tmp;
781 SCM tl;
782 SCM ans;
783 int c;
784
785 c = scm_flush_ws (port, name);
786 if (term_char == c)
787 return SCM_EOL;
788 scm_ungetc (c, port);
789 if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
790 {
791 ans = scm_lreadr (tok_buf, port, copy);
792 closeit:
793 if (term_char != (c = scm_flush_ws (port, name)))
794 scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL);
795 return ans;
796 }
797 ans = tl = scm_cons (tmp, SCM_EOL);
798 while (term_char != (c = scm_flush_ws (port, name)))
799 {
800 scm_ungetc (c, port);
801 if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
802 {
803 SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy));
804 goto closeit;
805 }
806 SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
807 tl = SCM_CDR (tl);
808 }
809 return ans;
810 }
811 #undef FUNC_NAME
812
813
814 SCM
815 scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
816 #define FUNC_NAME "scm_lreadrecparen"
817 {
818 register int c;
819 register SCM tmp;
820 register SCM tl, tl2 = SCM_EOL;
821 SCM ans, ans2 = SCM_EOL;
822 /* Need to capture line and column numbers here. */
823 int line = SCM_LINUM (port);
824 int column = SCM_COL (port) - 1;
825
826 c = scm_flush_ws (port, name);
827 if (')' == c)
828 return SCM_EOL;
829 scm_ungetc (c, port);
830 if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
831 {
832 ans = scm_lreadr (tok_buf, port, copy);
833 if (')' != (c = scm_flush_ws (port, name)))
834 scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL);
835 return ans;
836 }
837 /* Build the head of the list structure. */
838 ans = tl = scm_cons (tmp, SCM_EOL);
839 if (SCM_COPY_SOURCE_P)
840 ans2 = tl2 = scm_cons (scm_is_pair (tmp)
841 ? *copy
842 : tmp,
843 SCM_EOL);
844 while (')' != (c = scm_flush_ws (port, name)))
845 {
846 SCM new_tail;
847
848 scm_ungetc (c, port);
849 if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy))))
850 {
851 SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy));
852 if (SCM_COPY_SOURCE_P)
853 SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp)
854 ? *copy
855 : tmp,
856 SCM_EOL));
857 if (')' != (c = scm_flush_ws (port, name)))
858 scm_i_input_error (FUNC_NAME, port,
859 "missing close paren", SCM_EOL);
860 goto exit;
861 }
862
863 new_tail = scm_cons (tmp, SCM_EOL);
864 SCM_SETCDR (tl, new_tail);
865 tl = new_tail;
866
867 if (SCM_COPY_SOURCE_P)
868 {
869 SCM new_tail2 = scm_cons (scm_is_pair (tmp) ? *copy : tmp, SCM_EOL);
870 SCM_SETCDR (tl2, new_tail2);
871 tl2 = new_tail2;
872 }
873 }
874 exit:
875 scm_whash_insert (scm_source_whash,
876 ans,
877 scm_make_srcprops (line,
878 column,
879 SCM_FILENAME (port),
880 SCM_COPY_SOURCE_P
881 ? *copy = ans2
882 : SCM_UNDEFINED,
883 SCM_EOL));
884 return ans;
885 }
886 #undef FUNC_NAME
887
888
889 \f
890
891 /* Manipulate the read-hash-procedures alist. This could be written in
892 Scheme, but maybe it will also be used by C code during initialisation. */
893 SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
894 (SCM chr, SCM proc),
895 "Install the procedure @var{proc} for reading expressions\n"
896 "starting with the character sequence @code{#} and @var{chr}.\n"
897 "@var{proc} will be called with two arguments: the character\n"
898 "@var{chr} and the port to read further data from. The object\n"
899 "returned will be the return value of @code{read}.")
900 #define FUNC_NAME s_scm_read_hash_extend
901 {
902 SCM this;
903 SCM prev;
904
905 SCM_VALIDATE_CHAR (1, chr);
906 SCM_ASSERT (scm_is_false (proc)
907 || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
908 proc, SCM_ARG2, FUNC_NAME);
909
910 /* Check if chr is already in the alist. */
911 this = *scm_read_hash_procedures;
912 prev = SCM_BOOL_F;
913 while (1)
914 {
915 if (scm_is_null (this))
916 {
917 /* not found, so add it to the beginning. */
918 if (scm_is_true (proc))
919 {
920 *scm_read_hash_procedures =
921 scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
922 }
923 break;
924 }
925 if (scm_is_eq (chr, SCM_CAAR (this)))
926 {
927 /* already in the alist. */
928 if (scm_is_false (proc))
929 {
930 /* remove it. */
931 if (scm_is_false (prev))
932 {
933 *scm_read_hash_procedures =
934 SCM_CDR (*scm_read_hash_procedures);
935 }
936 else
937 scm_set_cdr_x (prev, SCM_CDR (this));
938 }
939 else
940 {
941 /* replace it. */
942 scm_set_cdr_x (SCM_CAR (this), proc);
943 }
944 break;
945 }
946 prev = this;
947 this = SCM_CDR (this);
948 }
949
950 return SCM_UNSPECIFIED;
951 }
952 #undef FUNC_NAME
953
954 /* Recover the read-hash procedure corresponding to char c. */
955 static SCM
956 scm_get_hash_procedure (int c)
957 {
958 SCM rest = *scm_read_hash_procedures;
959
960 while (1)
961 {
962 if (scm_is_null (rest))
963 return SCM_BOOL_F;
964
965 if (SCM_CHAR (SCM_CAAR (rest)) == c)
966 return SCM_CDAR (rest);
967
968 rest = SCM_CDR (rest);
969 }
970 }
971
972 void
973 scm_init_read ()
974 {
975 scm_read_hash_procedures =
976 SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));
977
978 scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
979 #include "libguile/read.x"
980 }
981
982 /*
983 Local Variables:
984 c-file-style: "gnu"
985 End:
986 */