1 /* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008 Free Software
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.
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.
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
33 #include "libguile/_scm.h"
34 #include "libguile/chars.h"
35 #include "libguile/eval.h"
36 #include "libguile/unif.h"
37 #include "libguile/keywords.h"
38 #include "libguile/alist.h"
39 #include "libguile/srcprop.h"
40 #include "libguile/hashtab.h"
41 #include "libguile/hash.h"
42 #include "libguile/ports.h"
43 #include "libguile/root.h"
44 #include "libguile/strings.h"
45 #include "libguile/strports.h"
46 #include "libguile/vectors.h"
47 #include "libguile/validate.h"
48 #include "libguile/srfi-4.h"
49 #include "libguile/srfi-13.h"
51 #include "libguile/read.h"
55 SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
56 SCM_SYMBOL (scm_keyword_prefix, "prefix");
57 SCM_SYMBOL (scm_keyword_postfix, "postfix");
59 scm_t_option scm_read_opts[] = {
60 { SCM_OPTION_BOOLEAN, "copy", 0,
61 "Copy source code expressions." },
62 { SCM_OPTION_BOOLEAN, "positions", 0,
63 "Record positions of source code expressions." },
64 { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
65 "Convert symbols to lower case."},
66 { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
67 "Style of keyword recognition: #f, 'prefix or 'postfix."}
70 { SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
71 "Support Elisp vector syntax, namely `[...]'."},
72 { SCM_OPTION_BOOLEAN, "elisp-strings", 0,
73 "Support `\\(' and `\\)' in strings."}
78 Give meaningful error messages for errors
82 FILE:LINE:COL: MESSAGE
85 This is not standard GNU format, but the test-suite likes the real
86 message to be in front.
92 scm_i_input_error (char const *function,
93 SCM port, const char *message, SCM arg)
95 SCM fn = (scm_is_string (SCM_FILENAME(port))
97 : scm_from_locale_string ("#<unknown port>"));
99 SCM string_port = scm_open_output_string ();
100 SCM string = SCM_EOL;
101 scm_simple_format (string_port,
102 scm_from_locale_string ("~A:~S:~S: ~A"),
104 scm_from_long (SCM_LINUM (port) + 1),
105 scm_from_int (SCM_COL (port) + 1),
106 scm_from_locale_string (message)));
108 string = scm_get_output_string (string_port);
109 scm_close_output_port (string_port);
110 scm_error_scm (scm_from_locale_symbol ("read-error"),
111 function? scm_from_locale_string (function) : SCM_BOOL_F,
118 SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
120 "Option interface for the read options. Instead of using\n"
121 "this procedure directly, use the procedures @code{read-enable},\n"
122 "@code{read-disable}, @code{read-set!} and @code{read-options}.")
123 #define FUNC_NAME s_scm_read_options
125 SCM ans = scm_options (setting,
129 if (SCM_COPY_SOURCE_P)
130 SCM_RECORD_POSITIONS_P = 1;
135 /* An association list mapping extra hash characters to procedures. */
136 static SCM *scm_read_hash_procedures;
143 /* Size of the C buffer used to read symbols and numbers. */
144 #define READER_BUFFER_SIZE 128
146 /* Size of the C buffer used to read strings. */
147 #define READER_STRING_BUFFER_SIZE 512
149 /* The maximum size of Scheme character names. */
150 #define READER_CHAR_NAME_MAX_SIZE 50
153 /* `isblank' is only in C99. */
154 #define CHAR_IS_BLANK_(_chr) \
155 (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n') \
156 || ((_chr) == '\f') || ((_chr) == '\r'))
159 # define CHAR_IS_BLANK(_chr) \
160 ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26))
162 # define CHAR_IS_BLANK CHAR_IS_BLANK_
166 /* R5RS one-character delimiters (see section 7.1.1, ``Lexical
168 #define CHAR_IS_R5RS_DELIMITER(c) \
170 || (c == ')') || (c == '(') || (c == ';') || (c == '"'))
172 #define CHAR_IS_DELIMITER CHAR_IS_R5RS_DELIMITER
174 /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
176 #define CHAR_IS_EXPONENT_MARKER(_chr) \
177 (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \
178 || ((_chr) == 'd') || ((_chr) == 'l'))
180 /* An inlinable version of `scm_c_downcase ()'. */
181 #define CHAR_DOWNCASE(_chr) \
182 (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
185 #ifndef HAVE_DECL_STRNCASECMP
186 extern int strncasecmp (char const *s1, char const *s2, size_t n);
189 #ifndef HAVE_STRNCASECMP
190 /* XXX: Use Gnulib's `strncasecmp ()'. */
193 strncasecmp (const char *s1, const char *s2, size_t len2)
195 while (*s1 && *s2 && len2 > 0)
197 int c1 = *s1, c2 = *s2;
199 if (CHAR_DOWNCASE (c1) != CHAR_DOWNCASE (c2))
208 return !(*s1 || *s2 || len2 > 0);
213 /* Read an SCSH block comment. */
214 static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
216 /* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
217 zero if the whole token fits in BUF, non-zero otherwise. */
219 read_token (SCM port, char *buf, size_t buf_size, size_t *read)
223 while (*read < buf_size)
227 chr = scm_getc (port);
228 chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr);
232 else if (CHAR_IS_DELIMITER (chr))
234 scm_ungetc (chr, port);
248 /* Skip whitespace from PORT and return the first non-whitespace character
249 read. Raise an error on end-of-file. */
251 flush_ws (SCM port, const char *eoferr)
255 switch (c = scm_getc (port))
261 scm_i_input_error (eoferr,
270 switch (c = scm_getc (port))
276 case SCM_LINE_INCREMENTORS:
282 switch (c = scm_getc (port))
285 eoferr = "read_sharp";
288 scm_read_scsh_block_comment (c, port);
291 scm_ungetc (c, port);
296 case SCM_LINE_INCREMENTORS:
297 case SCM_SINGLE_SPACES:
312 static SCM scm_read_expression (SCM port);
313 static SCM scm_read_sharp (int chr, SCM port);
314 static SCM scm_get_hash_procedure (int c);
315 static SCM recsexpr (SCM obj, long line, int column, SCM filename);
319 scm_read_sexp (int chr, SCM port)
320 #define FUNC_NAME "scm_i_lreadparen"
324 register SCM tl, ans = SCM_EOL;
325 SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
326 static const int terminating_char = ')';
328 /* Need to capture line and column numbers here. */
329 long line = SCM_LINUM (port);
330 int column = SCM_COL (port) - 1;
333 c = flush_ws (port, FUNC_NAME);
334 if (terminating_char == c)
337 scm_ungetc (c, port);
338 if (scm_is_eq (scm_sym_dot,
339 (tmp = scm_read_expression (port))))
341 ans = scm_read_expression (port);
342 if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
343 scm_i_input_error (FUNC_NAME, port, "missing close paren",
348 /* Build the head of the list structure. */
349 ans = tl = scm_cons (tmp, SCM_EOL);
351 if (SCM_COPY_SOURCE_P)
352 ans2 = tl2 = scm_cons (scm_is_pair (tmp)
357 while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
361 scm_ungetc (c, port);
362 if (scm_is_eq (scm_sym_dot,
363 (tmp = scm_read_expression (port))))
365 SCM_SETCDR (tl, tmp = scm_read_expression (port));
367 if (SCM_COPY_SOURCE_P)
368 SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
371 c = flush_ws (port, FUNC_NAME);
372 if (terminating_char != c)
373 scm_i_input_error (FUNC_NAME, port,
374 "in pair: missing close paren", SCM_EOL);
378 new_tail = scm_cons (tmp, SCM_EOL);
379 SCM_SETCDR (tl, new_tail);
382 if (SCM_COPY_SOURCE_P)
384 SCM new_tail2 = scm_cons (scm_is_pair (tmp)
387 SCM_SETCDR (tl2, new_tail2);
393 if (SCM_RECORD_POSITIONS_P)
394 scm_whash_insert (scm_source_whash,
396 scm_make_srcprops (line, column,
407 scm_read_string (int chr, SCM port)
408 #define FUNC_NAME "scm_lreadr"
410 /* For strings smaller than C_STR, this function creates only one Scheme
411 object (the string returned). */
413 SCM str = SCM_BOOL_F;
414 char c_str[READER_STRING_BUFFER_SIZE];
415 unsigned c_str_len = 0;
418 while ('"' != (c = scm_getc (port)))
421 str_eof: scm_i_input_error (FUNC_NAME, port,
422 "end of file in string constant",
425 if (c_str_len + 1 >= sizeof (c_str))
427 /* Flush the C buffer onto a Scheme string. */
430 if (str == SCM_BOOL_F)
431 str = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
433 addy = scm_from_locale_stringn (c_str, c_str_len);
434 str = scm_string_append_shared (scm_list_2 (str, addy));
440 switch (c = scm_getc (port))
450 if (SCM_ESCAPED_PARENS_P)
481 if (a == EOF) goto str_eof;
483 if (b == EOF) goto str_eof;
484 if ('0' <= a && a <= '9') a -= '0';
485 else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
486 else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
487 else goto bad_escaped;
488 if ('0' <= b && b <= '9') b -= '0';
489 else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
490 else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
491 else goto bad_escaped;
497 scm_i_input_error (FUNC_NAME, port,
498 "illegal character in escape sequence: ~S",
499 scm_list_1 (SCM_MAKE_CHAR (c)));
501 c_str[c_str_len++] = c;
508 addy = scm_from_locale_stringn (c_str, c_str_len);
509 if (str == SCM_BOOL_F)
512 str = scm_string_append_shared (scm_list_2 (str, addy));
515 str = (str == SCM_BOOL_F) ? scm_nullstr : str;
523 scm_read_number (int chr, SCM port)
525 SCM result, str = SCM_EOL;
526 char buffer[READER_BUFFER_SIZE];
530 scm_ungetc (chr, port);
533 overflow = read_token (port, buffer, sizeof (buffer), &read);
535 if ((overflow) || (scm_is_pair (str)))
536 str = scm_cons (scm_from_locale_stringn (buffer, read), str);
540 if (scm_is_pair (str))
544 str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
545 result = scm_string_to_number (str, SCM_UNDEFINED);
546 if (!scm_is_true (result))
547 /* Return a symbol instead of a number. */
548 result = scm_string_to_symbol (str);
552 result = scm_c_locale_stringn_to_number (buffer, read, 10);
553 if (!scm_is_true (result))
554 /* Return a symbol instead of a number. */
555 result = scm_from_locale_symboln (buffer, read);
562 scm_read_mixed_case_symbol (int chr, SCM port)
564 SCM result, str = SCM_EOL;
565 int overflow = 0, ends_with_colon = 0;
566 char buffer[READER_BUFFER_SIZE];
568 int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
570 scm_ungetc (chr, port);
573 overflow = read_token (port, buffer, sizeof (buffer), &read);
576 ends_with_colon = (buffer[read - 1] == ':');
578 if ((overflow) || (scm_is_pair (str)))
579 str = scm_cons (scm_from_locale_stringn (buffer, read), str);
583 if (scm_is_pair (str))
587 str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
588 len = scm_c_string_length (str);
590 /* Per SRFI-88, `:' alone is an identifier, not a keyword. */
591 if (postfix && ends_with_colon && (len > 1))
593 /* Strip off colon. */
594 str = scm_c_substring (str, 0, len-1);
595 result = scm_string_to_symbol (str);
596 result = scm_symbol_to_keyword (result);
599 result = scm_string_to_symbol (str);
603 /* For symbols smaller than `sizeof (buffer)', we don't need to recur
604 to Scheme strings. Therefore, we only create one Scheme object (a
605 symbol) per symbol read. */
606 if (postfix && ends_with_colon && (read > 1))
607 result = scm_from_locale_keywordn (buffer, read - 1);
609 result = scm_from_locale_symboln (buffer, read);
616 scm_read_number_and_radix (int chr, SCM port)
617 #define FUNC_NAME "scm_lreadr"
619 SCM result, str = SCM_EOL;
621 char buffer[READER_BUFFER_SIZE];
648 scm_ungetc (chr, port);
649 scm_ungetc ('#', port);
655 overflow = read_token (port, buffer, sizeof (buffer), &read);
657 if ((overflow) || (scm_is_pair (str)))
658 str = scm_cons (scm_from_locale_stringn (buffer, read), str);
662 if (scm_is_pair (str))
664 str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
665 result = scm_string_to_number (str, scm_from_uint (radix));
668 result = scm_c_locale_stringn_to_number (buffer, read, radix);
670 if (scm_is_true (result))
673 scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
680 scm_read_quote (int chr, SCM port)
683 long line = SCM_LINUM (port);
684 int column = SCM_COL (port) - 1;
689 p = scm_sym_quasiquote;
702 p = scm_sym_uq_splicing;
705 scm_ungetc (c, port);
712 fprintf (stderr, "%s: unhandled quote character (%i)\n",
713 "scm_read_quote", chr);
717 p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
718 if (SCM_RECORD_POSITIONS_P)
719 scm_whash_insert (scm_source_whash, p,
720 scm_make_srcprops (line, column,
723 ? (scm_cons2 (SCM_CAR (p),
724 SCM_CAR (SCM_CDR (p)),
734 scm_read_semicolon_comment (int chr, SCM port)
738 for (c = scm_getc (port);
739 (c != EOF) && (c != '\n');
740 c = scm_getc (port));
742 return SCM_UNSPECIFIED;
746 /* Sharp readers, i.e. readers called after a `#' sign has been read. */
749 scm_read_boolean (int chr, SCM port)
762 return SCM_UNSPECIFIED;
766 scm_read_character (int chr, SCM port)
767 #define FUNC_NAME "scm_lreadr"
770 char charname[READER_CHAR_NAME_MAX_SIZE];
773 if (read_token (port, charname, sizeof (charname), &charname_len))
776 if (charname_len == 0)
778 chr = scm_getc (port);
780 scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
781 "while reading character", SCM_EOL);
783 /* CHR must be a token delimiter, like a whitespace. */
784 return (SCM_MAKE_CHAR (chr));
787 if (charname_len == 1)
788 return SCM_MAKE_CHAR (charname[0]);
790 if (*charname >= '0' && *charname < '8')
792 /* Dirk:FIXME:: This type of character syntax is not R5RS
793 * compliant. Further, it should be verified that the constant
794 * does only consist of octal digits. Finally, it should be
795 * checked whether the resulting fixnum is in the range of
797 SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8);
799 return SCM_MAKE_CHAR (SCM_I_INUM (p));
802 for (c = 0; c < scm_n_charnames; c++)
804 && (!strncasecmp (scm_charnames[c], charname, charname_len)))
805 return SCM_MAKE_CHAR (scm_charnums[c]);
808 scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
809 scm_list_1 (scm_from_locale_stringn (charname,
812 return SCM_UNSPECIFIED;
817 scm_read_keyword (int chr, SCM port)
821 /* Read the symbol that comprises the keyword. Doing this instead of
822 invoking a specific symbol reader function allows `scm_read_keyword ()'
823 to adapt to the delimiters currently valid of symbols.
825 XXX: This implementation allows sloppy syntaxes like `#: key'. */
826 symbol = scm_read_expression (port);
827 if (!scm_is_symbol (symbol))
828 scm_i_input_error ("scm_read_keyword", port,
829 "keyword prefix `~a' not followed by a symbol: ~s",
830 scm_list_2 (SCM_MAKE_CHAR (chr), symbol));
832 return (scm_symbol_to_keyword (symbol));
836 scm_read_vector (int chr, SCM port)
838 /* Note: We call `scm_read_sexp ()' rather than READER here in order to
839 guarantee that it's going to do what we want. After all, this is an
840 implementation detail of `scm_read_vector ()', not a desirable
842 return (scm_vector (scm_read_sexp (chr, port)));
846 scm_read_srfi4_vector (int chr, SCM port)
848 return scm_i_read_array (port, chr);
852 scm_read_guile_bit_vector (int chr, SCM port)
854 /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
855 terribly inefficient but who cares? */
856 SCM s_bits = SCM_EOL;
858 for (chr = scm_getc (port);
859 (chr != EOF) && ((chr == '0') || (chr == '1'));
860 chr = scm_getc (port))
862 s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
866 scm_ungetc (chr, port);
868 return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
872 scm_read_scsh_block_comment (int chr, SCM port)
878 int c = scm_getc (port);
881 scm_i_input_error ("skip_block_comment", port,
882 "unterminated `#! ... !#' comment", SCM_EOL);
886 else if (c == '#' && bang_seen)
892 return SCM_UNSPECIFIED;
896 scm_read_extended_symbol (int chr, SCM port)
898 /* Guile's extended symbol read syntax looks like this:
900 #{This is all a symbol name}#
902 So here, CHR is expected to be `{'. */
904 int saw_brace = 0, finished = 0;
908 result = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
910 while ((chr = scm_getc (port)) != EOF)
931 if (len >= sizeof (buf) - 2)
933 scm_string_append (scm_list_2 (result,
934 scm_from_locale_stringn (buf, len)));
943 result = scm_string_append (scm_list_2
945 scm_from_locale_stringn (buf, len)));
947 return (scm_string_to_symbol (result));
952 /* Top-level token readers, i.e., dispatchers. */
955 scm_read_sharp_extension (int chr, SCM port)
959 proc = scm_get_hash_procedure (chr);
960 if (scm_is_true (scm_procedure_p (proc)))
962 long line = SCM_LINUM (port);
963 int column = SCM_COL (port) - 2;
966 got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
967 if (!scm_is_eq (got, SCM_UNSPECIFIED))
969 if (SCM_RECORD_POSITIONS_P)
970 return (recsexpr (got, line, column,
971 SCM_FILENAME (port)));
977 return SCM_UNSPECIFIED;
980 /* The reader for the sharp `#' character. It basically dispatches reads
981 among the above token readers. */
983 scm_read_sharp (int chr, SCM port)
984 #define FUNC_NAME "scm_lreadr"
988 chr = scm_getc (port);
990 result = scm_read_sharp_extension (chr, port);
991 if (!scm_is_eq (result, SCM_UNSPECIFIED))
997 return (scm_read_character (chr, port));
999 return (scm_read_vector (chr, port));
1003 /* This one may return either a boolean or an SRFI-4 vector. */
1004 return (scm_read_srfi4_vector (chr, port));
1006 return (scm_read_guile_bit_vector (chr, port));
1010 /* This one may return either a boolean or an SRFI-4 vector. */
1011 return (scm_read_boolean (chr, port));
1013 return (scm_read_keyword (chr, port));
1014 case '0': case '1': case '2': case '3': case '4':
1015 case '5': case '6': case '7': case '8': case '9':
1017 #if SCM_ENABLE_DEPRECATED
1018 /* See below for 'i' and 'e'. */
1025 return (scm_i_read_array (port, chr));
1029 #if SCM_ENABLE_DEPRECATED
1031 /* When next char is '(', it really is an old-style
1033 int next_c = scm_getc (port);
1035 scm_ungetc (next_c, port);
1037 return scm_i_read_array (port, chr);
1051 return (scm_read_number_and_radix (chr, port));
1053 return (scm_read_extended_symbol (chr, port));
1055 return (scm_read_scsh_block_comment (chr, port));
1057 result = scm_read_sharp_extension (chr, port);
1058 if (scm_is_eq (result, SCM_UNSPECIFIED))
1059 scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
1060 scm_list_1 (SCM_MAKE_CHAR (chr)));
1065 return SCM_UNSPECIFIED;
1070 scm_read_expression (SCM port)
1071 #define FUNC_NAME "scm_read_expression"
1077 chr = scm_getc (port);
1081 case SCM_WHITE_SPACES:
1082 case SCM_LINE_INCREMENTORS:
1085 (void) scm_read_semicolon_comment (chr, port);
1088 return (scm_read_sexp (chr, port));
1090 return (scm_read_string (chr, port));
1094 return (scm_read_quote (chr, port));
1098 result = scm_read_sharp (chr, port);
1099 if (scm_is_eq (result, SCM_UNSPECIFIED))
1100 /* We read a comment or some such. */
1106 scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
1111 if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
1112 return scm_symbol_to_keyword (scm_read_expression (port));
1117 if (((chr >= '0') && (chr <= '9'))
1118 || (strchr ("+-.", chr)))
1119 return (scm_read_number (chr, port));
1121 return (scm_read_mixed_case_symbol (chr, port));
1129 /* Actual reader. */
1131 SCM_DEFINE (scm_read, "read", 0, 1, 0,
1133 "Read an s-expression from the input port @var{port}, or from\n"
1134 "the current input port if @var{port} is not specified.\n"
1135 "Any whitespace before the next token is discarded.")
1136 #define FUNC_NAME s_scm_read
1140 if (SCM_UNBNDP (port))
1141 port = scm_current_input_port ();
1142 SCM_VALIDATE_OPINPORT (1, port);
1144 c = flush_ws (port, (char *) NULL);
1147 scm_ungetc (c, port);
1149 return (scm_read_expression (port));
1156 /* Used when recording expressions constructed by `scm_read_sharp ()'. */
1158 recsexpr (SCM obj, long line, int column, SCM filename)
1160 if (!scm_is_pair(obj)) {
1163 SCM tmp = obj, copy;
1164 /* If this sexpr is visible in the read:sharp source, we want to
1165 keep that information, so only record non-constant cons cells
1166 which haven't previously been read by the reader. */
1167 if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
1169 if (SCM_COPY_SOURCE_P)
1171 copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
1173 while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
1175 SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
1180 copy = SCM_CDR (copy);
1182 SCM_SETCDR (copy, tmp);
1186 recsexpr (SCM_CAR (obj), line, column, filename);
1187 while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
1188 recsexpr (SCM_CAR (tmp), line, column, filename);
1189 copy = SCM_UNDEFINED;
1191 scm_whash_insert (scm_source_whash,
1193 scm_make_srcprops (line,
1203 /* Manipulate the read-hash-procedures alist. This could be written in
1204 Scheme, but maybe it will also be used by C code during initialisation. */
1205 SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
1206 (SCM chr, SCM proc),
1207 "Install the procedure @var{proc} for reading expressions\n"
1208 "starting with the character sequence @code{#} and @var{chr}.\n"
1209 "@var{proc} will be called with two arguments: the character\n"
1210 "@var{chr} and the port to read further data from. The object\n"
1211 "returned will be the return value of @code{read}.")
1212 #define FUNC_NAME s_scm_read_hash_extend
1217 SCM_VALIDATE_CHAR (1, chr);
1218 SCM_ASSERT (scm_is_false (proc)
1219 || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
1220 proc, SCM_ARG2, FUNC_NAME);
1222 /* Check if chr is already in the alist. */
1223 this = *scm_read_hash_procedures;
1227 if (scm_is_null (this))
1229 /* not found, so add it to the beginning. */
1230 if (scm_is_true (proc))
1232 *scm_read_hash_procedures =
1233 scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
1237 if (scm_is_eq (chr, SCM_CAAR (this)))
1239 /* already in the alist. */
1240 if (scm_is_false (proc))
1243 if (scm_is_false (prev))
1245 *scm_read_hash_procedures =
1246 SCM_CDR (*scm_read_hash_procedures);
1249 scm_set_cdr_x (prev, SCM_CDR (this));
1254 scm_set_cdr_x (SCM_CAR (this), proc);
1259 this = SCM_CDR (this);
1262 return SCM_UNSPECIFIED;
1266 /* Recover the read-hash procedure corresponding to char c. */
1268 scm_get_hash_procedure (int c)
1270 SCM rest = *scm_read_hash_procedures;
1274 if (scm_is_null (rest))
1277 if (SCM_CHAR (SCM_CAAR (rest)) == c)
1278 return SCM_CDAR (rest);
1280 rest = SCM_CDR (rest);
1287 scm_read_hash_procedures =
1288 SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));
1290 scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
1291 #include "libguile/read.x"