summaryrefslogtreecommitdiff
path: root/libguile/read.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/read.c')
-rw-r--r--libguile/read.c2403
1 files changed, 2403 insertions, 0 deletions
diff --git a/libguile/read.c b/libguile/read.c
new file mode 100644
index 000000000..da21f615a
--- /dev/null
+++ b/libguile/read.c
@@ -0,0 +1,2403 @@
+/* Copyright 1995-1997,1999-2001,2003-2004,2006-2012,2014-2015,2018
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile is free software: you can redistribute it and/or modify it
+ under the terms of the GNU Lesser General Public License as published
+ by the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ Guile is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
+
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+#include <c-ctype.h>
+#include <c-strcase.h>
+#include <stdio.h>
+#include <string.h>
+#include <unicase.h>
+#include <unictype.h>
+#include <unistd.h>
+
+#include "alist.h"
+#include "arrays.h"
+#include "bitvectors.h"
+#include "boolean.h"
+#include "bytevectors.h"
+#include "chars.h"
+#include "eq.h"
+#include "eval.h"
+#include "fluids.h"
+#include "fports.h"
+#include "gsubr.h"
+#include "hash.h"
+#include "hashtab.h"
+#include "keywords.h"
+#include "modules.h"
+#include "numbers.h"
+#include "pairs.h"
+#include "ports-internal.h"
+#include "ports.h"
+#include "private-options.h"
+#include "procs.h"
+#include "srcprop.h"
+#include "srfi-13.h"
+#include "srfi-4.h"
+#include "strings.h"
+#include "strports.h"
+#include "symbols.h"
+#include "variable.h"
+#include "vectors.h"
+
+#include "read.h"
+
+
+
+
+SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
+SCM_SYMBOL (scm_keyword_prefix, "prefix");
+SCM_SYMBOL (scm_keyword_postfix, "postfix");
+SCM_SYMBOL (sym_nil, "nil");
+SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1");
+
+/* SRFI-105 curly infix expression support */
+SCM_SYMBOL (sym_nfx, "$nfx$");
+SCM_SYMBOL (sym_bracket_list, "$bracket-list$");
+SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$");
+
+scm_t_option scm_read_opts[] =
+ {
+ { SCM_OPTION_BOOLEAN, "copy", 0,
+ "Copy source code expressions." },
+ { SCM_OPTION_BOOLEAN, "positions", 1,
+ "Record positions of source code expressions." },
+ { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
+ "Convert symbols to lower case."},
+ { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
+ "Style of keyword recognition: #f, 'prefix or 'postfix."},
+ { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
+ "Use R6RS variable-length character and string hex escapes."},
+ { SCM_OPTION_BOOLEAN, "square-brackets", 1,
+ "Treat `[' and `]' as parentheses, for R6RS compatibility."},
+ { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0,
+ "In strings, consume leading whitespace after an escaped end-of-line."},
+ { SCM_OPTION_BOOLEAN, "curly-infix", 0,
+ "Support SRFI-105 curly infix expressions."},
+ { SCM_OPTION_BOOLEAN, "r7rs-symbols", 0,
+ "Support R7RS |...| symbol notation."},
+ { 0, },
+ };
+
+/* Internal read options structure. This is initialized by 'scm_read'
+ from the global and per-port read options, and a pointer is passed
+ down to all helper functions. */
+
+enum t_keyword_style
+ {
+ KEYWORD_STYLE_HASH_PREFIX,
+ KEYWORD_STYLE_PREFIX,
+ KEYWORD_STYLE_POSTFIX
+ };
+
+struct t_read_opts
+{
+ enum t_keyword_style keyword_style;
+ unsigned int copy_source_p : 1;
+ unsigned int record_positions_p : 1;
+ unsigned int case_insensitive_p : 1;
+ unsigned int r6rs_escapes_p : 1;
+ unsigned int square_brackets_p : 1;
+ unsigned int hungry_eol_escapes_p : 1;
+ unsigned int curly_infix_p : 1;
+ unsigned int neoteric_p : 1;
+ unsigned int r7rs_symbols_p : 1;
+};
+
+typedef struct t_read_opts scm_t_read_opts;
+
+
+/*
+ Give meaningful error messages for errors
+
+ We use the format
+
+ FILE:LINE:COL: MESSAGE
+ This happened in ....
+
+ This is not standard GNU format, but the test-suite likes the real
+ message to be in front.
+
+ */
+
+
+void
+scm_i_input_error (char const *function,
+ SCM port, const char *message, SCM arg)
+{
+ SCM fn = (scm_is_string (SCM_FILENAME(port))
+ ? SCM_FILENAME(port)
+ : scm_from_locale_string ("#<unknown port>"));
+
+ SCM string_port = scm_open_output_string ();
+ SCM string = SCM_EOL;
+ scm_simple_format (string_port,
+ scm_from_locale_string ("~A:~S:~S: ~A"),
+ scm_list_4 (fn,
+ scm_sum (scm_port_line (port), SCM_INUM1),
+ scm_sum (scm_port_column (port), SCM_INUM1),
+ scm_from_locale_string (message)));
+
+ string = scm_get_output_string (string_port);
+ scm_close_output_port (string_port);
+ scm_error_scm (scm_from_latin1_symbol ("read-error"),
+ function? scm_from_locale_string (function) : SCM_BOOL_F,
+ string,
+ arg,
+ SCM_BOOL_F);
+}
+
+
+SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the read options. Instead of using\n"
+ "this procedure directly, use the procedures @code{read-enable},\n"
+ "@code{read-disable}, @code{read-set!} and @code{read-options}.")
+#define FUNC_NAME s_scm_read_options
+{
+ SCM ans = scm_options (setting,
+ scm_read_opts,
+ FUNC_NAME);
+ if (SCM_COPY_SOURCE_P)
+ SCM_RECORD_POSITIONS_P = 1;
+ return ans;
+}
+#undef FUNC_NAME
+
+/* A fluid referring to an association list mapping extra hash
+ characters to procedures. */
+static SCM *scm_i_read_hash_procedures;
+
+static SCM
+scm_i_read_hash_procedures_ref (void)
+{
+ return scm_fluid_ref (*scm_i_read_hash_procedures);
+}
+
+static void
+scm_i_read_hash_procedures_set_x (SCM value)
+{
+ scm_fluid_set_x (*scm_i_read_hash_procedures, value);
+}
+
+
+/* Token readers. */
+
+
+/* Size of the C buffer used to read symbols and numbers. */
+#define READER_BUFFER_SIZE 128
+
+/* Number of 32-bit codepoints in the buffer used to read strings. */
+#define READER_STRING_BUFFER_SIZE 128
+
+/* The maximum size of Scheme character names. */
+#define READER_CHAR_NAME_MAX_SIZE 50
+
+/* The maximum size of reader directive names. */
+#define READER_DIRECTIVE_NAME_MAX_SIZE 50
+
+
+/* `isblank' is only in C99. */
+#define CHAR_IS_BLANK_(_chr) \
+ (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n') \
+ || ((_chr) == '\f') || ((_chr) == '\r'))
+
+#ifdef MSDOS
+# define CHAR_IS_BLANK(_chr) \
+ ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26))
+#else
+# define CHAR_IS_BLANK CHAR_IS_BLANK_
+#endif
+
+
+/* R5RS one-character delimiters (see section 7.1.1, ``Lexical
+ structure''). */
+#define CHAR_IS_R5RS_DELIMITER(c) \
+ (CHAR_IS_BLANK (c) \
+ || (c) == ')' || (c) == '(' || (c) == ';' || (c) == '"')
+
+#define CHAR_IS_DELIMITER(c) \
+ (CHAR_IS_R5RS_DELIMITER (c) \
+ || (((c) == ']' || (c) == '[') && (opts->square_brackets_p \
+ || opts->curly_infix_p)) \
+ || (((c) == '}' || (c) == '{') && opts->curly_infix_p))
+
+/* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
+ Structure''. */
+#define CHAR_IS_EXPONENT_MARKER(_chr) \
+ (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \
+ || ((_chr) == 'd') || ((_chr) == 'l'))
+
+/* Read an SCSH block comment. */
+static SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
+static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM);
+static SCM scm_read_commented_expression (scm_t_wchar, SCM, scm_t_read_opts *);
+static SCM scm_read_shebang (scm_t_wchar, SCM, scm_t_read_opts *);
+static SCM scm_get_hash_procedure (int);
+
+/* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the
+ result in the pre-allocated buffer BUF. Return zero if the whole token has
+ fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number of
+ bytes actually read. */
+static int
+read_token (SCM port, scm_t_read_opts *opts,
+ char *buf, size_t buf_size, size_t *read)
+{
+ *read = 0;
+
+ while (*read < buf_size)
+ {
+ int chr;
+
+ chr = scm_get_byte_or_eof (port);
+
+ if (chr == EOF)
+ return 0;
+ else if (CHAR_IS_DELIMITER (chr))
+ {
+ scm_unget_byte (chr, port);
+ return 0;
+ }
+ else
+ {
+ *buf = (char) chr;
+ buf++, (*read)++;
+ }
+ }
+
+ return 1;
+ }
+
+/* Like `read_token', but return either BUFFER, or a GC-allocated buffer
+ if the token doesn't fit in BUFFER_SIZE bytes. */
+static char *
+read_complete_token (SCM port, scm_t_read_opts *opts,
+ char *buffer, size_t buffer_size, size_t *read)
+{
+ int overflow = 0;
+ size_t bytes_read, overflow_size = 0;
+ char *overflow_buffer = NULL;
+
+ do
+ {
+ overflow = read_token (port, opts, buffer, buffer_size, &bytes_read);
+ if (bytes_read == 0)
+ break;
+ if (overflow || overflow_size != 0)
+ {
+ if (overflow_size == 0)
+ {
+ overflow_buffer = scm_gc_malloc_pointerless (bytes_read, "read");
+ memcpy (overflow_buffer, buffer, bytes_read);
+ overflow_size = bytes_read;
+ }
+ else
+ {
+ char *new_buf =
+ scm_gc_malloc_pointerless (overflow_size + bytes_read, "read");
+
+ memcpy (new_buf, overflow_buffer, overflow_size);
+ memcpy (new_buf + overflow_size, buffer, bytes_read);
+
+ overflow_buffer = new_buf;
+ overflow_size += bytes_read;
+ }
+ }
+ }
+ while (overflow);
+
+ if (overflow_size)
+ *read = overflow_size;
+ else
+ *read = bytes_read;
+
+ return (overflow_size > 0 ? overflow_buffer : buffer);
+}
+
+/* Skip whitespace from PORT and return the first non-whitespace character
+ read. Raise an error on end-of-file. */
+static int
+flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr)
+{
+ scm_t_wchar c;
+ while (1)
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goteof:
+ if (eoferr)
+ {
+ scm_i_input_error (eoferr,
+ port,
+ "end of file",
+ SCM_EOL);
+ }
+ return c;
+
+ case ';':
+ lp:
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goto goteof;
+ default:
+ goto lp;
+ case SCM_LINE_INCREMENTORS:
+ break;
+ }
+ break;
+
+ case '#':
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ eoferr = "read_sharp";
+ goto goteof;
+ case '!':
+ scm_read_shebang (c, port, opts);
+ break;
+ case ';':
+ scm_read_commented_expression (c, port, opts);
+ break;
+ case '|':
+ if (scm_is_false (scm_get_hash_procedure (c)))
+ {
+ scm_read_r6rs_block_comment (c, port);
+ break;
+ }
+ /* fall through */
+ default:
+ scm_ungetc (c, port);
+ return '#';
+ }
+ break;
+
+ case SCM_LINE_INCREMENTORS:
+ case SCM_SINGLE_SPACES:
+ case '\t':
+ break;
+
+ default:
+ return c;
+ }
+
+ return 0;
+}
+
+
+
+/* Token readers. */
+
+static SCM scm_read_expression (SCM port, scm_t_read_opts *opts);
+static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts,
+ long line, int column);
+
+
+static SCM
+maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts,
+ long line, int column)
+{
+ /* This condition can be caused by a user calling
+ set-port-column!. */
+ if (line < 0 || column < 0)
+ return x;
+
+ if (opts->record_positions_p)
+ scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port));
+ return x;
+}
+
+static SCM
+scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "scm_i_lreadparen"
+{
+ int c;
+ SCM tmp, tl, ans = SCM_EOL;
+ const int curly_list_p = (chr == '{') && opts->curly_infix_p;
+ const int terminating_char = ((chr == '{') ? '}'
+ : ((chr == '[') ? ']'
+ : ')'));
+
+ /* Need to capture line and column numbers here. */
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 1;
+
+ c = flush_ws (port, opts, FUNC_NAME);
+ if (terminating_char == c)
+ return SCM_EOL;
+
+ scm_ungetc (c, port);
+ tmp = scm_read_expression (port, opts);
+
+ /* Note that it is possible for scm_read_expression to return
+ scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So
+ check that it's a real dot by checking `c'. */
+ if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
+ {
+ ans = scm_read_expression (port, opts);
+ if (terminating_char != (c = flush_ws (port, opts, FUNC_NAME)))
+ scm_i_input_error (FUNC_NAME, port, "missing close paren",
+ SCM_EOL);
+ return ans;
+ }
+
+ /* Build the head of the list structure. */
+ ans = tl = scm_cons (tmp, SCM_EOL);
+
+ while (terminating_char != (c = flush_ws (port, opts, FUNC_NAME)))
+ {
+ SCM new_tail;
+
+ if (c == ')' || (c == ']' && opts->square_brackets_p)
+ || ((c == '}' || c == ']') && opts->curly_infix_p))
+ scm_i_input_error (FUNC_NAME, port,
+ "in pair: mismatched close paren: ~A",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+
+ scm_ungetc (c, port);
+ tmp = scm_read_expression (port, opts);
+
+ /* See above note about scm_sym_dot. */
+ if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
+ {
+ SCM_SETCDR (tl, scm_read_expression (port, opts));
+
+ c = flush_ws (port, opts, FUNC_NAME);
+ if (terminating_char != c)
+ scm_i_input_error (FUNC_NAME, port,
+ "in pair: missing close paren", SCM_EOL);
+ break;
+ }
+
+ new_tail = scm_cons (tmp, SCM_EOL);
+ SCM_SETCDR (tl, new_tail);
+ tl = new_tail;
+ }
+
+ if (curly_list_p)
+ {
+ /* In addition to finding the length, 'scm_ilength' checks for
+ improper or circular lists, in which case it returns -1. */
+ int len = scm_ilength (ans);
+
+ /* The (len == 0) case is handled above */
+ if (len == 1)
+ /* Return directly to avoid re-annotating the element's source
+ location with the position of the outer brace. Also, it
+ might not be possible to annotate the element. */
+ return scm_car (ans); /* {e} => e */
+ else if (len == 2)
+ ; /* Leave the list unchanged: {e1 e2} => (e1 e2) */
+ else if (len >= 3 && (len & 1))
+ {
+ /* It's a proper list whose length is odd and at least 3. If
+ the elements at odd indices (the infix operator positions)
+ are all 'equal?', then it's a simple curly-infix list.
+ Otherwise it's a mixed curly-infix list. */
+ SCM op = scm_cadr (ans);
+
+ /* Check to see if the elements at odd indices are 'equal?' */
+ for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl))
+ {
+ if (scm_is_null (tl))
+ {
+ /* Convert simple curly-infix list to prefix:
+ {a <op> b <op> ...} => (<op> a b ...) */
+ tl = ans;
+ while (scm_is_pair (scm_cdr (tl)))
+ {
+ tmp = scm_cddr (tl);
+ SCM_SETCDR (tl, tmp);
+ tl = tmp;
+ }
+ ans = scm_cons (op, ans);
+ break;
+ }
+ else if (scm_is_false (scm_equal_p (op, scm_car (tl))))
+ {
+ /* Mixed curly-infix list: {e ...} => ($nfx$ e ...) */
+ ans = scm_cons (sym_nfx, ans);
+ break;
+ }
+ }
+ }
+ else
+ /* Mixed curly-infix (possibly improper) list:
+ {e . tail} => ($nfx$ e . tail) */
+ ans = scm_cons (sym_nfx, ans);
+ }
+
+ return maybe_annotate_source (ans, port, opts, line, column);
+}
+#undef FUNC_NAME
+
+
+/* Read a hexadecimal number NDIGITS in length. Put its value into the variable
+ C. If TERMINATOR is non-null, terminate early if the TERMINATOR character is
+ found. */
+#define SCM_READ_HEX_ESCAPE(ndigits, terminator) \
+ do \
+ { \
+ scm_t_wchar a; \
+ size_t i = 0; \
+ c = 0; \
+ while (i < ndigits) \
+ { \
+ a = scm_getc (port); \
+ if (a == EOF) \
+ goto str_eof; \
+ if (terminator \
+ && (a == (scm_t_wchar) terminator) \
+ && (i > 0)) \
+ break; \
+ if ('0' <= a && a <= '9') \
+ a -= '0'; \
+ else if ('A' <= a && a <= 'F') \
+ a = a - 'A' + 10; \
+ else if ('a' <= a && a <= 'f') \
+ a = a - 'a' + 10; \
+ else \
+ { \
+ c = a; \
+ goto bad_escaped; \
+ } \
+ c = c * 16 + a; \
+ i ++; \
+ } \
+ } while (0)
+
+static void
+skip_intraline_whitespace (SCM port)
+{
+ scm_t_wchar c;
+
+ do
+ {
+ c = scm_getc (port);
+ if (c == EOF)
+ return;
+ }
+ while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR));
+
+ scm_ungetc (c, port);
+}
+
+/* Read either a double-quoted string or an R7RS-style symbol delimited
+ by vertical lines, depending on the value of 'chr' ('"' or '|').
+ Regardless, the result is always returned as a string. */
+static SCM
+scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "scm_lreadr"
+{
+ /* For strings smaller than C_STR, this function creates only one Scheme
+ object (the string returned). */
+
+ SCM str = SCM_EOL;
+ size_t c_str_len = 0;
+ scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE];
+
+ /* Need to capture line and column numbers here. */
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 1;
+
+ while (chr != (c = scm_getc (port)))
+ {
+ if (c == EOF)
+ {
+ str_eof:
+ scm_i_input_error (FUNC_NAME, port,
+ (chr == '|'
+ ? "end of file in symbol"
+ : "end of file in string constant"),
+ SCM_EOL);
+ }
+
+ if (c_str_len + 1 >= READER_STRING_BUFFER_SIZE)
+ {
+ str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
+ c_str_len = 0;
+ }
+
+ if (c == '\\')
+ {
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goto str_eof;
+ case '|':
+ case '\\':
+ case '(': /* Accept "\(" for use at the beginning of lines
+ in multiline strings to avoid confusing emacs
+ lisp modes. */
+ break;
+ case '\n':
+ if (opts->hungry_eol_escapes_p)
+ skip_intraline_whitespace (port);
+ continue;
+ case '0':
+ c = '\0';
+ break;
+ case 'f':
+ c = '\f';
+ break;
+ case 'n':
+ c = '\n';
+ break;
+ case 'r':
+ c = '\r';
+ break;
+ case 't':
+ c = '\t';
+ break;
+ case 'a':
+ c = '\007';
+ break;
+ case 'v':
+ c = '\v';
+ break;
+ case 'b':
+ c = '\010';
+ break;
+ case 'x':
+ if (opts->r6rs_escapes_p || chr == '|')
+ SCM_READ_HEX_ESCAPE (10, ';');
+ else
+ SCM_READ_HEX_ESCAPE (2, '\0');
+ break;
+ case 'u':
+ if (!opts->r6rs_escapes_p)
+ {
+ SCM_READ_HEX_ESCAPE (4, '\0');
+ break;
+ }
+ case 'U':
+ if (!opts->r6rs_escapes_p)
+ {
+ SCM_READ_HEX_ESCAPE (6, '\0');
+ break;
+ }
+ default:
+ if (c == chr)
+ break;
+ bad_escaped:
+ scm_i_input_error (FUNC_NAME, port,
+ "illegal character in escape sequence: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ }
+ }
+
+ c_str[c_str_len++] = c;
+ }
+
+ if (scm_is_null (str))
+ /* Fast path: we got a string that fits in C_STR. */
+ str = scm_from_utf32_stringn (c_str, c_str_len);
+ else
+ {
+ if (c_str_len > 0)
+ str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
+
+ str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED);
+ }
+
+ return maybe_annotate_source (str, port, opts, line, column);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_read_string (int chr, SCM port, scm_t_read_opts *opts)
+{
+ return scm_read_string_like_syntax (chr, port, opts);
+}
+
+static SCM
+scm_read_r7rs_symbol (int chr, SCM port, scm_t_read_opts *opts)
+{
+ return scm_string_to_symbol (scm_read_string_like_syntax (chr, port, opts));
+}
+
+static SCM
+scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
+{
+ SCM result, str = SCM_EOL;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
+ size_t bytes_read;
+
+ /* Need to capture line and column numbers here. */
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 1;
+
+ scm_ungetc (chr, port);
+ buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
+ &bytes_read);
+
+ str = scm_from_port_stringn (buffer, bytes_read, port);
+
+ result = scm_string_to_number (str, SCM_UNDEFINED);
+ if (scm_is_false (result))
+ {
+ /* Return a symbol instead of a number */
+ if (opts->case_insensitive_p)
+ str = scm_string_downcase_x (str);
+ result = scm_string_to_symbol (str);
+ }
+ else if (SCM_NIMP (result))
+ result = maybe_annotate_source (result, port, opts, line, column);
+
+ scm_set_port_column_x (port,
+ scm_sum (scm_port_column (port),
+ scm_string_length (str)));
+ return result;
+}
+
+static SCM
+scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
+{
+ SCM result;
+ int ends_with_colon = 0;
+ size_t bytes_read;
+ int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX);
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
+ SCM str;
+
+ scm_ungetc (chr, port);
+ buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
+ &bytes_read);
+ if (bytes_read > 0)
+ ends_with_colon = buffer[bytes_read - 1] == ':';
+
+ if (postfix && ends_with_colon && (bytes_read > 1))
+ {
+ str = scm_from_port_stringn (buffer, bytes_read - 1, port);
+
+ if (opts->case_insensitive_p)
+ str = scm_string_downcase_x (str);
+ result = scm_symbol_to_keyword (scm_string_to_symbol (str));
+ }
+ else
+ {
+ str = scm_from_port_stringn (buffer, bytes_read, port);
+
+ if (opts->case_insensitive_p)
+ str = scm_string_downcase_x (str);
+ result = scm_string_to_symbol (str);
+ }
+
+ scm_set_port_column_x (port,
+ scm_sum (scm_port_column (port),
+ scm_string_length (str)));
+ return result;
+}
+
+static SCM
+scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "scm_lreadr"
+{
+ SCM result;
+ size_t read;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
+ unsigned int radix;
+ SCM str;
+
+ switch (chr)
+ {
+ case 'B':
+ case 'b':
+ radix = 2;
+ break;
+
+ case 'o':
+ case 'O':
+ radix = 8;
+ break;
+
+ case 'd':
+ case 'D':
+ radix = 10;
+ break;
+
+ case 'x':
+ case 'X':
+ radix = 16;
+ break;
+
+ default:
+ scm_ungetc (chr, port);
+ scm_ungetc ('#', port);
+ radix = 10;
+ }
+
+ buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
+ &read);
+
+ str = scm_from_port_stringn (buffer, read, port);
+
+ result = scm_string_to_number (str, scm_from_uint (radix));
+
+ scm_set_port_column_x (port,
+ scm_sum (scm_port_column (port),
+ scm_string_length (str)));
+
+ if (scm_is_true (result))
+ return result;
+
+ scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+static SCM
+scm_read_quote (int chr, SCM port, scm_t_read_opts *opts)
+{
+ SCM p;
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 1;
+
+ switch (chr)
+ {
+ case '`':
+ p = scm_sym_quasiquote;
+ break;
+
+ case '\'':
+ p = scm_sym_quote;
+ break;
+
+ case ',':
+ {
+ scm_t_wchar c;
+
+ c = scm_getc (port);
+ if ('@' == c)
+ p = scm_sym_uq_splicing;
+ else
+ {
+ scm_ungetc (c, port);
+ p = scm_sym_unquote;
+ }
+ break;
+ }
+
+ default:
+ fprintf (stderr, "%s: unhandled quote character (%i)\n",
+ "scm_read_quote", chr);
+ abort ();
+ }
+
+ p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL);
+ return maybe_annotate_source (p, port, opts, line, column);
+}
+
+SCM_SYMBOL (sym_syntax, "syntax");
+SCM_SYMBOL (sym_quasisyntax, "quasisyntax");
+SCM_SYMBOL (sym_unsyntax, "unsyntax");
+SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");
+
+static SCM
+scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts)
+{
+ SCM p;
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 1;
+
+ switch (chr)
+ {
+ case '`':
+ p = sym_quasisyntax;
+ break;
+
+ case '\'':
+ p = sym_syntax;
+ break;
+
+ case ',':
+ {
+ int c;
+
+ c = scm_getc (port);
+ if ('@' == c)
+ p = sym_unsyntax_splicing;
+ else
+ {
+ scm_ungetc (c, port);
+ p = sym_unsyntax;
+ }
+ break;
+ }
+
+ default:
+ fprintf (stderr, "%s: unhandled syntax character (%i)\n",
+ "scm_read_syntax", chr);
+ abort ();
+ }
+
+ p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL);
+ return maybe_annotate_source (p, port, opts, line, column);
+}
+
+static SCM
+scm_read_nil (int chr, SCM port, scm_t_read_opts *opts)
+{
+ SCM id = scm_read_mixed_case_symbol (chr, port, opts);
+
+ if (!scm_is_eq (id, sym_nil))
+ scm_i_input_error ("scm_read_nil", port,
+ "unexpected input while reading #nil: ~a",
+ scm_list_1 (id));
+
+ return SCM_ELISP_NIL;
+}
+
+static SCM
+scm_read_semicolon_comment (int chr, SCM port)
+{
+ int c;
+
+ /* We use the get_byte here because there is no need to get the
+ locale correct with comment input. This presumes that newline
+ always represents itself no matter what the encoding is. */
+ for (c = scm_get_byte_or_eof (port);
+ (c != EOF) && (c != '\n');
+ c = scm_get_byte_or_eof (port));
+
+ return SCM_UNSPECIFIED;
+}
+
+/* If the EXPECTED_CHARS are the next ones available from PORT, then
+ consume them and return 1. Otherwise leave the port position where
+ it was and return 0. EXPECTED_CHARS should be all lowercase, and
+ will be matched case-insensitively against the characters read from
+ PORT. */
+static int
+try_read_ci_chars (SCM port, const char *expected_chars)
+{
+ int num_chars_wanted = strlen (expected_chars);
+ int num_chars_read = 0;
+ char *chars_read = alloca (num_chars_wanted);
+ int c;
+
+ while (num_chars_read < num_chars_wanted)
+ {
+ c = scm_getc (port);
+ if (c == EOF)
+ break;
+ else if (c_tolower (c) != expected_chars[num_chars_read])
+ {
+ scm_ungetc (c, port);
+ break;
+ }
+ else
+ chars_read[num_chars_read++] = c;
+ }
+
+ if (num_chars_read == num_chars_wanted)
+ return 1;
+ else
+ {
+ while (num_chars_read > 0)
+ scm_ungetc (chars_read[--num_chars_read], port);
+ return 0;
+ }
+}
+
+
+/* Sharp readers, i.e. readers called after a `#' sign has been read. */
+
+static SCM
+scm_read_boolean (int chr, SCM port)
+{
+ switch (chr)
+ {
+ case 't':
+ case 'T':
+ try_read_ci_chars (port, "rue");
+ return SCM_BOOL_T;
+
+ case 'f':
+ case 'F':
+ try_read_ci_chars (port, "alse");
+ return SCM_BOOL_F;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "scm_lreadr"
+{
+ char buffer[READER_CHAR_NAME_MAX_SIZE];
+ SCM charname;
+ size_t charname_len, bytes_read;
+ scm_t_wchar cp;
+ int overflow;
+ scm_t_port *pt;
+
+ overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE,
+ &bytes_read);
+ if (overflow)
+ scm_i_input_error (FUNC_NAME, port, "character name too long", SCM_EOL);
+
+ if (bytes_read == 0)
+ {
+ chr = scm_getc (port);
+ if (chr == EOF)
+ scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
+ "while reading character", SCM_EOL);
+
+ /* CHR must be a token delimiter, like a whitespace. */
+ return (SCM_MAKE_CHAR (chr));
+ }
+
+ pt = SCM_PORT (port);
+
+ /* Simple ASCII characters can be processed immediately. Also, simple
+ ISO-8859-1 characters can be processed immediately if the encoding for this
+ port is ISO-8859-1. */
+ if (bytes_read == 1 &&
+ ((unsigned char) buffer[0] <= 127
+ || scm_is_eq (pt->encoding, sym_ISO_8859_1)))
+ {
+ scm_set_port_column_x (port, scm_sum (scm_port_column (port), SCM_INUM1));
+ return SCM_MAKE_CHAR (buffer[0]);
+ }
+
+ /* Otherwise, convert the buffer into a proper scheme string for
+ processing. */
+ charname = scm_from_port_stringn (buffer, bytes_read, port);
+ charname_len = scm_i_string_length (charname);
+ scm_set_port_column_x (port,
+ scm_sum (scm_port_column (port),
+ scm_from_size_t (charname_len)));
+ cp = scm_i_string_ref (charname, 0);
+ if (charname_len == 1)
+ return SCM_MAKE_CHAR (cp);
+
+ /* Ignore dotted circles, which may be used to keep combining characters from
+ combining with the backslash in #\charname. */
+ if (cp == SCM_CODEPOINT_DOTTED_CIRCLE && charname_len == 2)
+ return SCM_MAKE_CHAR (scm_i_string_ref (charname, 1));
+
+ if (cp >= '0' && cp < '8')
+ {
+ /* Dirk:FIXME:: This type of character syntax is not R5RS
+ * compliant. Further, it should be verified that the constant
+ * does only consist of octal digits. */
+ SCM p = scm_string_to_number (charname, scm_from_uint (8));
+ if (SCM_I_INUMP (p))
+ {
+ scm_t_wchar c = scm_to_uint32 (p);
+ if (SCM_IS_UNICODE_CHAR (c))
+ return SCM_MAKE_CHAR (c);
+ else
+ scm_i_input_error (FUNC_NAME, port,
+ "out-of-range octal character escape: ~a",
+ scm_list_1 (charname));
+ }
+ }
+
+ if (cp == 'x' && (charname_len > 1))
+ {
+ SCM p;
+
+ /* Convert from hex, skipping the initial 'x' character in CHARNAME */
+ p = scm_string_to_number (scm_c_substring (charname, 1, charname_len),
+ scm_from_uint (16));
+ if (SCM_I_INUMP (p))
+ {
+ scm_t_wchar c = scm_to_uint32 (p);
+ if (SCM_IS_UNICODE_CHAR (c))
+ return SCM_MAKE_CHAR (c);
+ else
+ scm_i_input_error (FUNC_NAME, port,
+ "out-of-range hex character escape: ~a",
+ scm_list_1 (charname));
+ }
+ }
+
+ /* The names of characters should never have non-Latin1
+ characters. */
+ if (scm_i_is_narrow_string (charname)
+ || scm_i_try_narrow_string (charname))
+ { SCM ch = scm_i_charname_to_char (scm_i_string_chars (charname),
+ charname_len);
+ if (scm_is_true (ch))
+ return ch;
+ }
+
+ scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
+ scm_list_1 (charname));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts)
+{
+ SCM symbol;
+
+ /* Read the symbol that comprises the keyword. Doing this instead of
+ invoking a specific symbol reader function allows `scm_read_keyword ()'
+ to adapt to the delimiters currently valid of symbols.
+
+ XXX: This implementation allows sloppy syntaxes like `#: key'. */
+ symbol = scm_read_expression (port, opts);
+ if (!scm_is_symbol (symbol))
+ scm_i_input_error ("scm_read_keyword", port,
+ "keyword prefix `~a' not followed by a symbol: ~s",
+ scm_list_2 (SCM_MAKE_CHAR (chr), symbol));
+
+ return (scm_symbol_to_keyword (symbol));
+}
+
+static SCM
+scm_read_vector (int chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
+{
+ /* Note: We call `scm_read_sexp ()' rather than READER here in order to
+ guarantee that it's going to do what we want. After all, this is an
+ implementation detail of `scm_read_vector ()', not a desirable
+ property. */
+ return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port, opts)),
+ port, opts, line, column);
+}
+
+/* Helper used by scm_read_array */
+static int
+read_decimal_integer (SCM port, int c, ssize_t *resp)
+{
+ ssize_t sign = 1;
+ ssize_t res = 0;
+ int got_it = 0;
+
+ if (c == '-')
+ {
+ sign = -1;
+ c = scm_getc (port);
+ }
+
+ while ('0' <= c && c <= '9')
+ {
+ if (((SSIZE_MAX - (c-'0')) / 10) <= res)
+ scm_i_input_error ("read_decimal_integer", port,
+ "number too large", SCM_EOL);
+ res = 10*res + c-'0';
+ got_it = 1;
+ c = scm_getc (port);
+ }
+
+ if (got_it)
+ *resp = sign * res;
+ return c;
+}
+
+/* Read an array. This function can also read vectors and uniform
+ vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
+ handled here.
+
+ C is the first character read after the '#'. */
+static SCM
+scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column)
+{
+ ssize_t rank;
+ scm_t_wchar tag_buf[8];
+ int tag_len;
+
+ SCM tag, shape = SCM_BOOL_F, elements, array;
+
+ /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
+ the array code can not deal with zero-length dimensions yet, and
+ we want to allow zero-length vectors, of course. */
+ if (c == '(')
+ return scm_read_vector (c, port, opts, line, column);
+
+ /* Disambiguate between '#f' and uniform floating point vectors. */
+ if (c == 'f')
+ {
+ c = scm_getc (port);
+ if (c != '3' && c != '6')
+ {
+ if (c == 'a' && try_read_ci_chars (port, "lse"))
+ return SCM_BOOL_F;
+ else if (c != EOF)
+ scm_ungetc (c, port);
+ return SCM_BOOL_F;
+ }
+ rank = 1;
+ tag_buf[0] = 'f';
+ tag_len = 1;
+ goto continue_reading_tag;
+ }
+
+ /* Read rank. */
+ rank = 1;
+ c = read_decimal_integer (port, c, &rank);
+ if (rank < 0)
+ scm_i_input_error (NULL, port, "array rank must be non-negative",
+ SCM_EOL);
+
+ /* Read tag. */
+ tag_len = 0;
+ continue_reading_tag:
+ while (c != EOF && c != '(' && c != '@' && c != ':'
+ && tag_len < sizeof tag_buf / sizeof tag_buf[0])
+ {
+ tag_buf[tag_len++] = c;
+ c = scm_getc (port);
+ }
+ if (tag_len == 0)
+ tag = SCM_BOOL_T;
+ else
+ {
+ tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
+ if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
+ scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
+ scm_list_1 (tag));
+ }
+
+ /* Read shape. */
+ if (c == '@' || c == ':')
+ {
+ shape = SCM_EOL;
+
+ do
+ {
+ ssize_t lbnd = 0, len = 0;
+ SCM s;
+
+ if (c == '@')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &lbnd);
+ }
+
+ s = scm_from_ssize_t (lbnd);
+
+ if (c == ':')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &len);
+ if (len < 0)
+ scm_i_input_error (NULL, port,
+ "array length must be non-negative",
+ SCM_EOL);
+
+ s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
+ }
+
+ shape = scm_cons (s, shape);
+ } while (c == '@' || c == ':');
+
+ shape = scm_reverse_x (shape, SCM_EOL);
+ }
+
+ /* Read nested lists of elements. */
+ if (c != '(')
+ scm_i_input_error (NULL, port,
+ "missing '(' in vector or array literal",
+ SCM_EOL);
+ elements = scm_read_sexp (c, port, opts);
+
+ if (scm_is_false (shape))
+ shape = scm_from_ssize_t (rank);
+ else if (scm_ilength (shape) != rank)
+ scm_i_input_error
+ (NULL, port,
+ "the number of shape specifications must match the array rank",
+ SCM_EOL);
+
+ /* Handle special print syntax of rank zero arrays; see
+ scm_i_print_array for a rationale. */
+ if (rank == 0)
+ {
+ if (!scm_is_pair (elements))
+ scm_i_input_error (NULL, port,
+ "too few elements in array literal, need 1",
+ SCM_EOL);
+ if (!scm_is_null (SCM_CDR (elements)))
+ scm_i_input_error (NULL, port,
+ "too many elements in array literal, want 1",
+ SCM_EOL);
+ elements = SCM_CAR (elements);
+ }
+
+ /* Construct array, annotate with source location, and return. */
+ array = scm_list_to_typed_array (tag, shape, elements);
+ return maybe_annotate_source (array, port, opts, line, column);
+}
+
+static SCM
+scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
+{
+ return scm_read_array (chr, port, opts, line, column);
+}
+
+static SCM
+scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
+{
+ chr = scm_getc (port);
+ if (chr != 'u')
+ goto syntax;
+
+ chr = scm_getc (port);
+ if (chr != '8')
+ goto syntax;
+
+ chr = scm_getc (port);
+ if (chr != '(')
+ goto syntax;
+
+ return maybe_annotate_source
+ (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts)),
+ port, opts, line, column);
+
+ syntax:
+ scm_i_input_error ("read_bytevector", port,
+ "invalid bytevector prefix",
+ SCM_MAKE_CHAR (chr));
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
+{
+ /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
+ terribly inefficient but who cares? */
+ SCM s_bits = SCM_EOL;
+
+ for (chr = scm_getc (port);
+ (chr != EOF) && ((chr == '0') || (chr == '1'));
+ chr = scm_getc (port))
+ {
+ s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
+ }
+
+ if (chr != EOF)
+ scm_ungetc (chr, port);
+
+ return maybe_annotate_source
+ (scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)),
+ port, opts, line, column);
+}
+
+static SCM
+scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
+{
+ int bang_seen = 0;
+
+ for (;;)
+ {
+ int c = scm_getc (port);
+
+ if (c == EOF)
+ scm_i_input_error ("skip_block_comment", port,
+ "unterminated `#! ... !#' comment", SCM_EOL);
+
+ if (c == '!')
+ bang_seen = 1;
+ else if (c == '#' && bang_seen)
+ break;
+ else
+ bang_seen = 0;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_keyword_style (SCM port, scm_t_read_opts *opts,
+ enum t_keyword_style value);
+
+static SCM
+scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
+{
+ char name[READER_DIRECTIVE_NAME_MAX_SIZE + 1];
+ int c;
+ int i = 0;
+
+ while (i <= READER_DIRECTIVE_NAME_MAX_SIZE)
+ {
+ c = scm_getc (port);
+ if (c == EOF)
+ scm_i_input_error ("skip_block_comment", port,
+ "unterminated `#! ... !#' comment", SCM_EOL);
+ else if (('a' <= c && c <= 'z') || ('0' <= c && c <= '9') || c == '-')
+ name[i++] = c;
+ else if (CHAR_IS_DELIMITER (c))
+ {
+ scm_ungetc (c, port);
+ name[i] = '\0';
+ if (0 == strcmp ("r6rs", name))
+ {
+ set_port_case_insensitive_p (port, opts, 0);
+ set_port_r6rs_hex_escapes_p (port, opts, 1);
+ set_port_square_brackets_p (port, opts, 1);
+ set_port_keyword_style (port, opts, KEYWORD_STYLE_HASH_PREFIX);
+ set_port_hungry_eol_escapes_p (port, opts, 1);
+ }
+ else if (0 == strcmp ("fold-case", name))
+ set_port_case_insensitive_p (port, opts, 1);
+ else if (0 == strcmp ("no-fold-case", name))
+ set_port_case_insensitive_p (port, opts, 0);
+ else if (0 == strcmp ("curly-infix", name))
+ set_port_curly_infix_p (port, opts, 1);
+ else if (0 == strcmp ("curly-infix-and-bracket-lists", name))
+ {
+ set_port_curly_infix_p (port, opts, 1);
+ set_port_square_brackets_p (port, opts, 0);
+ }
+ else
+ break;
+
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ scm_ungetc (c, port);
+ break;
+ }
+ }
+ while (i > 0)
+ scm_ungetc (name[--i], port);
+ return scm_read_scsh_block_comment (chr, port);
+}
+
+static SCM
+scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
+{
+ /* Unlike SCSH-style block comments, SRFI-30/R6RS block comments may be
+ nested. So care must be taken. */
+ int nesting_level = 1;
+
+ int a = scm_getc (port);
+
+ if (a == EOF)
+ scm_i_input_error ("scm_read_r6rs_block_comment", port,
+ "unterminated `#| ... |#' comment", SCM_EOL);
+
+ while (nesting_level > 0)
+ {
+ int b = scm_getc (port);
+
+ if (b == EOF)
+ scm_i_input_error ("scm_read_r6rs_block_comment", port,
+ "unterminated `#| ... |#' comment", SCM_EOL);
+
+ if (a == '|' && b == '#')
+ {
+ nesting_level--;
+ b = EOF;
+ }
+ else if (a == '#' && b == '|')
+ {
+ nesting_level++;
+ b = EOF;
+ }
+
+ a = b;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+scm_read_commented_expression (scm_t_wchar chr, SCM port,
+ scm_t_read_opts *opts)
+{
+ scm_t_wchar c;
+
+ c = flush_ws (port, opts, (char *) NULL);
+ if (EOF == c)
+ scm_i_input_error ("read_commented_expression", port,
+ "no expression after #; comment", SCM_EOL);
+ scm_ungetc (c, port);
+ scm_read_expression (port, opts);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+scm_read_extended_symbol (scm_t_wchar chr, SCM port)
+{
+ /* Guile's extended symbol read syntax looks like this:
+
+ #{This is all a symbol name}#
+
+ So here, CHR is expected to be `{'. */
+ int saw_brace = 0;
+ size_t len = 0;
+ SCM buf = scm_i_make_string (1024, NULL, 0);
+
+ /* No need to scm_i_string_start_writing (), as the string isn't
+ visible to any other thread. */
+
+ while ((chr = scm_getc (port)) != EOF)
+ {
+ if (saw_brace)
+ {
+ if (chr == '#')
+ {
+ break;
+ }
+ else
+ {
+ saw_brace = 0;
+ scm_i_string_set_x (buf, len++, '}');
+ }
+ }
+
+ if (chr == '}')
+ saw_brace = 1;
+ else if (chr == '\\')
+ {
+ /* It used to be that print.c would print extended-read-syntax
+ symbols with backslashes before "non-standard" chars, but
+ this routine wouldn't do anything with those escapes.
+ Bummer. What we've done is to change print.c to output
+ R6RS hex escapes for those characters, relying on the fact
+ that the extended read syntax would never put a `\' before
+ an `x'. For now, we just ignore other instances of
+ backslash in the string. */
+ switch ((chr = scm_getc (port)))
+ {
+ case EOF:
+ goto done;
+ case 'x':
+ {
+ scm_t_wchar c;
+
+ SCM_READ_HEX_ESCAPE (10, ';');
+ scm_i_string_set_x (buf, len++, c);
+ break;
+
+ str_eof:
+ chr = EOF;
+ goto done;
+
+ bad_escaped:
+ scm_i_string_stop_writing ();
+ scm_i_input_error ("scm_read_extended_symbol", port,
+ "illegal character in escape sequence: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ break;
+ }
+ default:
+ scm_i_string_set_x (buf, len++, chr);
+ break;
+ }
+ }
+ else
+ scm_i_string_set_x (buf, len++, chr);
+
+ if (len >= scm_i_string_length (buf) - 2)
+ {
+ SCM addy;
+
+ addy = scm_i_make_string (1024, NULL, 0);
+ buf = scm_string_append (scm_list_2 (buf, addy));
+ len = 0;
+ }
+ }
+
+ done:
+ if (chr == EOF)
+ scm_i_input_error ("scm_read_extended_symbol", port,
+ "end of file while reading symbol", SCM_EOL);
+
+ return (scm_string_to_symbol (scm_c_substring (buf, 0, len)));
+}
+
+
+
+/* Top-level token readers, i.e., dispatchers. */
+
+static SCM
+scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts)
+{
+ SCM proc;
+
+ proc = scm_get_hash_procedure (chr);
+ if (scm_is_true (scm_procedure_p (proc)))
+ {
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 2;
+ SCM got;
+
+ got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
+
+ if (opts->record_positions_p && SCM_NIMP (got)
+ && !scm_i_has_source_properties (got))
+ scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));
+
+ return got;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+/* The reader for the sharp `#' character. It basically dispatches reads
+ among the above token readers. */
+static SCM
+scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
+#define FUNC_NAME "scm_lreadr"
+{
+ SCM result;
+
+ chr = scm_getc (port);
+
+ result = scm_read_sharp_extension (chr, port, opts);
+ if (!scm_is_eq (result, SCM_UNSPECIFIED))
+ return result;
+
+ switch (chr)
+ {
+ case '\\':
+ return (scm_read_character (chr, port, opts));
+ case '(':
+ return (scm_read_vector (chr, port, opts, line, column));
+ case 's':
+ case 'u':
+ case 'f':
+ case 'c':
+ /* This one may return either a boolean or an SRFI-4 vector. */
+ return (scm_read_srfi4_vector (chr, port, opts, line, column));
+ case 'v':
+ return (scm_read_bytevector (chr, port, opts, line, column));
+ case '*':
+ return (scm_read_guile_bit_vector (chr, port, opts, line, column));
+ case 't':
+ case 'T':
+ case 'F':
+ return (scm_read_boolean (chr, port));
+ case ':':
+ return (scm_read_keyword (chr, port, opts));
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ case '@':
+ return (scm_read_array (chr, port, opts, line, column));
+
+ case 'i':
+ case 'e':
+ case 'b':
+ case 'B':
+ case 'o':
+ case 'O':
+ case 'd':
+ case 'D':
+ case 'x':
+ case 'X':
+ case 'I':
+ case 'E':
+ return (scm_read_number_and_radix (chr, port, opts));
+ case '{':
+ return (scm_read_extended_symbol (chr, port));
+ case '!':
+ return (scm_read_shebang (chr, port, opts));
+ case ';':
+ return (scm_read_commented_expression (chr, port, opts));
+ case '`':
+ case '\'':
+ case ',':
+ return (scm_read_syntax (chr, port, opts));
+ case 'n':
+ return (scm_read_nil (chr, port, opts));
+ default:
+ result = scm_read_sharp_extension (chr, port, opts);
+ if (scm_is_eq (result, SCM_UNSPECIFIED))
+ {
+ /* To remain compatible with 1.8 and earlier, the following
+ characters have lower precedence than `read-hash-extend'
+ characters. */
+ switch (chr)
+ {
+ case '|':
+ return scm_read_r6rs_block_comment (chr, port);
+ default:
+ scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (chr)));
+ }
+ }
+ else
+ return result;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+read_inner_expression (SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "read_inner_expression"
+{
+ while (1)
+ {
+ scm_t_wchar chr;
+
+ chr = scm_getc (port);
+
+ switch (chr)
+ {
+ case SCM_WHITE_SPACES:
+ case SCM_LINE_INCREMENTORS:
+ break;
+ case ';':
+ (void) scm_read_semicolon_comment (chr, port);
+ break;
+ case '{':
+ if (opts->curly_infix_p)
+ {
+ if (opts->neoteric_p)
+ return scm_read_sexp (chr, port, opts);
+ else
+ {
+ SCM expr;
+
+ /* Enable neoteric expressions within curly braces */
+ opts->neoteric_p = 1;
+ expr = scm_read_sexp (chr, port, opts);
+ opts->neoteric_p = 0;
+ return expr;
+ }
+ }
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
+ case '[':
+ if (opts->square_brackets_p)
+ return scm_read_sexp (chr, port, opts);
+ else if (opts->curly_infix_p)
+ {
+ /* The syntax of neoteric expressions requires that '[' be
+ a delimiter when curly-infix is enabled, so it cannot
+ be part of an unescaped symbol. We might as well do
+ something useful with it, so we adopt Kawa's convention:
+ [...] => ($bracket-list$ ...) */
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 1;
+ return maybe_annotate_source
+ (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)),
+ port, opts, line, column);
+ }
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
+ case '(':
+ return (scm_read_sexp (chr, port, opts));
+ case '"':
+ return (scm_read_string (chr, port, opts));
+ case '|':
+ if (opts->r7rs_symbols_p)
+ return scm_read_r7rs_symbol (chr, port, opts);
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
+ case '\'':
+ case '`':
+ case ',':
+ return (scm_read_quote (chr, port, opts));
+ case '#':
+ {
+ long line = scm_to_long (scm_port_line (port));
+ int column = scm_to_int (scm_port_column (port)) - 1;
+ SCM result = scm_read_sharp (chr, port, opts, line, column);
+ if (scm_is_eq (result, SCM_UNSPECIFIED))
+ /* We read a comment or some such. */
+ break;
+ else
+ return result;
+ }
+ case ')':
+ scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
+ break;
+ case '}':
+ if (opts->curly_infix_p)
+ scm_i_input_error (FUNC_NAME, port, "unexpected \"}\"", SCM_EOL);
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
+ case ']':
+ if (opts->square_brackets_p)
+ scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL);
+ /* otherwise fall through */
+ case EOF:
+ return SCM_EOF_VAL;
+ case ':':
+ if (opts->keyword_style == KEYWORD_STYLE_PREFIX)
+ return scm_symbol_to_keyword (scm_read_expression (port, opts));
+ /* Fall through. */
+
+ default:
+ {
+ if (((chr >= '0') && (chr <= '9'))
+ || (strchr ("+-.", chr)))
+ return (scm_read_number (chr, port, opts));
+ else
+ return (scm_read_mixed_case_symbol (chr, port, opts));
+ }
+ }
+ }
+}
+#undef FUNC_NAME
+
+static SCM
+scm_read_expression (SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "scm_read_expression"
+{
+ if (!opts->neoteric_p)
+ return read_inner_expression (port, opts);
+ else
+ {
+ long line = 0;
+ int column = 0;
+ SCM expr;
+
+ if (opts->record_positions_p)
+ {
+ /* We need to get the position of the first non-whitespace
+ character in order to correctly annotate neoteric
+ expressions. For example, for the expression 'f(x)', the
+ first call to 'read_inner_expression' reads the 'f' (which
+ cannot be annotated), and then we later read the '(x)' and
+ use it to construct the new list (f x). */
+ int c = flush_ws (port, opts, (char *) NULL);
+ if (c == EOF)
+ return SCM_EOF_VAL;
+ scm_ungetc (c, port);
+ line = scm_to_long (scm_port_line (port));
+ column = scm_to_int (scm_port_column (port));
+ }
+
+ expr = read_inner_expression (port, opts);
+
+ /* 'expr' is the first component of the neoteric expression. Now
+ we loop, and as long as the next character is '(', '[', or '{',
+ (without any intervening whitespace), we use it to construct a
+ new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */
+ for (;;)
+ {
+ int chr = scm_getc (port);
+
+ if (chr == '(')
+ /* e(...) => (e ...) */
+ expr = scm_cons (expr, scm_read_sexp (chr, port, opts));
+ else if (chr == '[')
+ /* e[...] => ($bracket-apply$ e ...) */
+ expr = scm_cons (sym_bracket_apply,
+ scm_cons (expr,
+ scm_read_sexp (chr, port, opts)));
+ else if (chr == '{')
+ {
+ SCM arg = scm_read_sexp (chr, port, opts);
+
+ if (scm_is_null (arg))
+ expr = scm_list_1 (expr); /* e{} => (e) */
+ else
+ expr = scm_list_2 (expr, arg); /* e{...} => (e {...}) */
+ }
+ else
+ {
+ if (chr != EOF)
+ scm_ungetc (chr, port);
+ break;
+ }
+ maybe_annotate_source (expr, port, opts, line, column);
+ }
+ return expr;
+ }
+}
+#undef FUNC_NAME
+
+
+/* Actual reader. */
+
+static void init_read_options (SCM port, scm_t_read_opts *opts);
+
+SCM_DEFINE (scm_read, "read", 0, 1, 0,
+ (SCM port),
+ "Read an s-expression from the input port @var{port}, or from\n"
+ "the current input port if @var{port} is not specified.\n"
+ "Any whitespace before the next token is discarded.")
+#define FUNC_NAME s_scm_read
+{
+ scm_t_read_opts opts;
+ int c;
+
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1, port);
+
+ init_read_options (port, &opts);
+
+ c = flush_ws (port, &opts, (char *) NULL);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ scm_ungetc (c, port);
+
+ return (scm_read_expression (port, &opts));
+}
+#undef FUNC_NAME
+
+
+
+
+/* Manipulate the read-hash-procedures alist. This could be written in
+ Scheme, but maybe it will also be used by C code during initialisation. */
+SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
+ (SCM chr, SCM proc),
+ "Install the procedure @var{proc} for reading expressions\n"
+ "starting with the character sequence @code{#} and @var{chr}.\n"
+ "@var{proc} will be called with two arguments: the character\n"
+ "@var{chr} and the port to read further data from. The object\n"
+ "returned will be the return value of @code{read}. \n"
+ "Passing @code{#f} for @var{proc} will remove a previous setting. \n"
+ )
+#define FUNC_NAME s_scm_read_hash_extend
+{
+ SCM this;
+ SCM prev;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ SCM_ASSERT (scm_is_false (proc)
+ || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
+ proc, SCM_ARG2, FUNC_NAME);
+
+ /* Check if chr is already in the alist. */
+ this = scm_i_read_hash_procedures_ref ();
+ prev = SCM_BOOL_F;
+ while (1)
+ {
+ if (scm_is_null (this))
+ {
+ /* not found, so add it to the beginning. */
+ if (scm_is_true (proc))
+ {
+ SCM new = scm_cons (scm_cons (chr, proc),
+ scm_i_read_hash_procedures_ref ());
+ scm_i_read_hash_procedures_set_x (new);
+ }
+ break;
+ }
+ if (scm_is_eq (chr, SCM_CAAR (this)))
+ {
+ /* already in the alist. */
+ if (scm_is_false (proc))
+ {
+ /* remove it. */
+ if (scm_is_false (prev))
+ {
+ SCM rest = SCM_CDR (scm_i_read_hash_procedures_ref ());
+ scm_i_read_hash_procedures_set_x (rest);
+ }
+ else
+ scm_set_cdr_x (prev, SCM_CDR (this));
+ }
+ else
+ {
+ /* replace it. */
+ scm_set_cdr_x (SCM_CAR (this), proc);
+ }
+ break;
+ }
+ prev = this;
+ this = SCM_CDR (this);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Recover the read-hash procedure corresponding to char c. */
+static SCM
+scm_get_hash_procedure (int c)
+{
+ SCM rest = scm_i_read_hash_procedures_ref ();
+
+ while (1)
+ {
+ if (scm_is_null (rest))
+ return SCM_BOOL_F;
+
+ if (SCM_CHAR (SCM_CAAR (rest)) == c)
+ return SCM_CDAR (rest);
+
+ rest = SCM_CDR (rest);
+ }
+}
+
+static int
+is_encoding_char (char c)
+{
+ if (c >= 'a' && c <= 'z') return 1;
+ if (c >= 'A' && c <= 'Z') return 1;
+ if (c >= '0' && c <= '9') return 1;
+ return strchr ("_-.:/,+=()", c) != NULL;
+}
+
+/* Maximum size of an encoding name. This is a bit more than the
+ longest name listed at
+ <http://www.iana.org/assignments/character-sets> ("ISO-2022-JP-2", 13
+ characters.) */
+#define ENCODING_NAME_MAX_SIZE 20
+
+/* Number of bytes at the beginning or end of a file that are scanned
+ for a "coding:" declaration. */
+#define SCM_ENCODING_SEARCH_SIZE (500 + ENCODING_NAME_MAX_SIZE)
+
+
+/* Search the SCM_ENCODING_SEARCH_SIZE bytes of a file for an Emacs-like
+ coding declaration. Returns either NULL or a string whose storage
+ has been allocated with `scm_gc_malloc'. */
+char *
+scm_i_scan_for_encoding (SCM port)
+{
+ scm_t_port *pt;
+ SCM buf;
+ char header[SCM_ENCODING_SEARCH_SIZE+1];
+ size_t cur, bytes_read, encoding_length, i;
+ char *encoding = NULL;
+ char *pos, *encoding_start;
+ int in_comment;
+
+ pt = SCM_PORT (port);
+ buf = pt->read_buf;
+
+ if (pt->rw_random)
+ scm_flush (port);
+
+ if (scm_port_buffer_can_take (buf, &cur) == 0)
+ {
+ /* We can use the read buffer, and thus avoid a seek. */
+ buf = scm_fill_input (port, 0, &cur, &bytes_read);
+ if (bytes_read > SCM_ENCODING_SEARCH_SIZE)
+ bytes_read = SCM_ENCODING_SEARCH_SIZE;
+
+ if (bytes_read <= 1)
+ /* An unbuffered port -- don't scan. */
+ return NULL;
+
+ memcpy (header, scm_port_buffer_take_pointer (buf, cur), bytes_read);
+ header[bytes_read] = '\0';
+ }
+ else if (pt->rw_random)
+ {
+ /* The port is seekable. This is OK but grubbing in the read
+ buffer is better, so this case is just a fallback. */
+ bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+ header[bytes_read] = '\0';
+ scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
+ }
+ else
+ /* No input available and not seekable; scan fails. */
+ return NULL;
+
+ /* search past "coding[:=]" */
+ pos = header;
+ while (1)
+ {
+ if ((pos = strstr(pos, "coding")) == NULL)
+ return NULL;
+
+ pos += strlen ("coding");
+ if (pos - header >= SCM_ENCODING_SEARCH_SIZE ||
+ (*pos == ':' || *pos == '='))
+ {
+ pos ++;
+ break;
+ }
+ }
+
+ /* skip spaces */
+ while (pos - header <= SCM_ENCODING_SEARCH_SIZE &&
+ (*pos == ' ' || *pos == '\t'))
+ pos ++;
+
+ if (pos - header >= SCM_ENCODING_SEARCH_SIZE - ENCODING_NAME_MAX_SIZE)
+ /* We found the "coding:" string, but there is probably not enough
+ room to store an encoding name in its entirety, so ignore it.
+ This makes sure we do not end up returning a truncated encoding
+ name. */
+ return NULL;
+
+ /* grab the next token */
+ encoding_start = pos;
+ i = 0;
+ while (encoding_start + i - header <= SCM_ENCODING_SEARCH_SIZE
+ && encoding_start + i - header < bytes_read
+ && is_encoding_char (encoding_start[i]))
+ i++;
+
+ encoding_length = i;
+ if (encoding_length == 0)
+ return NULL;
+
+ encoding = scm_gc_strndup (encoding_start, encoding_length, "encoding");
+
+ /* push backwards to make sure we were in a comment */
+ in_comment = 0;
+ pos = encoding_start;
+ while (pos >= header)
+ {
+ if (*pos == ';')
+ {
+ in_comment = 1;
+ break;
+ }
+ else if (*pos == '\n' || pos == header)
+ {
+ /* This wasn't in a semicolon comment. Check for a
+ hash-bang comment. */
+ char *beg = strstr (header, "#!");
+ char *end = strstr (header, "!#");
+ if (beg < encoding_start && encoding_start + encoding_length <= end)
+ in_comment = 1;
+ break;
+ }
+ else
+ {
+ pos --;
+ continue;
+ }
+ }
+ if (!in_comment)
+ /* This wasn't in a comment */
+ return NULL;
+
+ return encoding;
+}
+
+SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
+ (SCM port),
+ "Scans the port for an Emacs-like character coding declaration\n"
+ "near the top of the contents of a port with random-accessible contents.\n"
+ "The coding declaration is of the form\n"
+ "@code{coding: XXXXX} and must appear in a scheme comment.\n"
+ "\n"
+ "Returns a string containing the character encoding of the file\n"
+ "if a declaration was found, or @code{#f} otherwise.\n")
+#define FUNC_NAME s_scm_file_encoding
+{
+ char *enc;
+ SCM s_enc;
+
+ SCM_VALIDATE_OPINPORT (SCM_ARG1, port);
+
+ enc = scm_i_scan_for_encoding (port);
+ if (enc == NULL)
+ return SCM_BOOL_F;
+ else
+ {
+ s_enc = scm_string_upcase (scm_from_locale_string (enc));
+ return s_enc;
+ }
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+/* Per-port read options.
+
+ We store per-port read options in the 'port-read-options' port
+ property, which is stored in the internal port structure. The value
+ stored is a single integer that contains a two-bit field for each
+ read option.
+
+ If a bit field contains READ_OPTION_INHERIT (3), that indicates that
+ the applicable value should be inherited from the corresponding
+ global read option. Otherwise, the bit field contains the value of
+ the read option. For boolean read options that have been set
+ per-port, the possible values are 0 or 1. If the 'keyword_style'
+ read option has been set per-port, its possible values are those in
+ 'enum t_keyword_style'. */
+
+/* Key to read options in port properties. */
+SCM_SYMBOL (sym_port_read_options, "port-read-options");
+
+/* Offsets of bit fields for each per-port override */
+#define READ_OPTION_COPY_SOURCE_P 0
+#define READ_OPTION_RECORD_POSITIONS_P 2
+#define READ_OPTION_CASE_INSENSITIVE_P 4
+#define READ_OPTION_KEYWORD_STYLE 6
+#define READ_OPTION_R6RS_ESCAPES_P 8
+#define READ_OPTION_SQUARE_BRACKETS_P 10
+#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12
+#define READ_OPTION_CURLY_INFIX_P 14
+#define READ_OPTION_R7RS_SYMBOLS_P 16
+
+/* The total width in bits of the per-port overrides */
+#define READ_OPTIONS_NUM_BITS 18
+
+#define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1)
+#define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL
+
+#define READ_OPTION_MASK 3
+#define READ_OPTION_INHERIT 3
+
+static void
+set_port_read_option (SCM port, int option, int new_value)
+{
+ SCM scm_read_options;
+ unsigned int read_options;
+
+ new_value &= READ_OPTION_MASK;
+
+ scm_read_options = scm_i_port_property (port, sym_port_read_options);
+ if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
+ read_options = scm_to_uint (scm_read_options);
+ else
+ read_options = READ_OPTIONS_INHERIT_ALL;
+ read_options &= ~(READ_OPTION_MASK << option);
+ read_options |= new_value << option;
+ scm_read_options = scm_from_uint (read_options);
+ scm_i_set_port_property_x (port, sym_port_read_options, scm_read_options);
+}
+
+/* Set OPTS and PORT's case-insensitivity according to VALUE. */
+static void
+set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->case_insensitive_p = value;
+ set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value);
+}
+
+/* Set OPTS and PORT's square_brackets_p option according to VALUE. */
+static void
+set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->square_brackets_p = value;
+ set_port_read_option (port, READ_OPTION_SQUARE_BRACKETS_P, value);
+}
+
+/* Set OPTS and PORT's curly_infix_p option according to VALUE. */
+static void
+set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->curly_infix_p = value;
+ set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value);
+}
+
+/* Set OPTS and PORT's r6rs_hex_escapes_p option according to VALUE. */
+static void
+set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->r6rs_escapes_p = value;
+ set_port_read_option (port, READ_OPTION_R6RS_ESCAPES_P, value);
+}
+
+static void
+set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->hungry_eol_escapes_p = value;
+ set_port_read_option (port, READ_OPTION_HUNGRY_EOL_ESCAPES_P, value);
+}
+
+static void
+set_port_keyword_style (SCM port, scm_t_read_opts *opts, enum t_keyword_style value)
+{
+ opts->keyword_style = value;
+ set_port_read_option (port, READ_OPTION_KEYWORD_STYLE, value);
+}
+
+/* Initialize OPTS based on PORT's read options and the global read
+ options. */
+static void
+init_read_options (SCM port, scm_t_read_opts *opts)
+{
+ SCM val, scm_read_options;
+ unsigned int read_options, x;
+
+ scm_read_options = scm_i_port_property (port, sym_port_read_options);
+
+ if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
+ read_options = scm_to_uint (scm_read_options);
+ else
+ read_options = READ_OPTIONS_INHERIT_ALL;
+
+ x = READ_OPTION_MASK & (read_options >> READ_OPTION_KEYWORD_STYLE);
+ if (x == READ_OPTION_INHERIT)
+ {
+ val = SCM_PACK (SCM_KEYWORD_STYLE);
+ if (scm_is_eq (val, scm_keyword_prefix))
+ x = KEYWORD_STYLE_PREFIX;
+ else if (scm_is_eq (val, scm_keyword_postfix))
+ x = KEYWORD_STYLE_POSTFIX;
+ else
+ x = KEYWORD_STYLE_HASH_PREFIX;
+ }
+ opts->keyword_style = x;
+
+#define RESOLVE_BOOLEAN_OPTION(NAME, name) \
+ do \
+ { \
+ x = READ_OPTION_MASK & (read_options >> READ_OPTION_ ## NAME); \
+ if (x == READ_OPTION_INHERIT) \
+ x = !!SCM_ ## NAME; \
+ opts->name = x; \
+ } \
+ while (0)
+
+ RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p);
+ RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p);
+ RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p);
+ RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p);
+ RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p);
+ RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p);
+ RESOLVE_BOOLEAN_OPTION (CURLY_INFIX_P, curly_infix_p);
+ RESOLVE_BOOLEAN_OPTION (R7RS_SYMBOLS_P, r7rs_symbols_p);
+
+#undef RESOLVE_BOOLEAN_OPTION
+
+ opts->neoteric_p = 0;
+}
+
+void
+scm_init_read ()
+{
+ SCM read_hash_procs;
+
+ read_hash_procs = scm_make_fluid_with_default (SCM_EOL);
+
+ scm_i_read_hash_procedures =
+ SCM_VARIABLE_LOC (scm_c_define ("%read-hash-procedures", read_hash_procs));
+
+ scm_init_opts (scm_read_options, scm_read_opts);
+#include "read.x"
+}