diff options
author | Andy Wingo <wingo@pobox.com> | 2021-03-03 22:17:16 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-03-03 22:17:16 +0100 |
commit | 38abf6b247f7c8c3c73c5d288c9b79c06c34cce7 (patch) | |
tree | 077d4f2bf098bf05bb67b70c2407eac5d1f6655f /libguile | |
parent | a1fdb76455a03cc7caeb06bdf857a0762477a530 (diff) | |
download | guile-38abf6b247f7c8c3c73c5d288c9b79c06c34cce7.tar.gz |
primitive-read handles only default reader options
* libguile/read.c: Remove support for all non-default reader options.
Also remove support for source positions. The idea is that
primitive-read should just be a stripped-down, easy-to-understand reader
that is enough to bootstrap the C reader. Probably more refactoring
will follow.
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/read.c | 778 |
1 files changed, 122 insertions, 656 deletions
diff --git a/libguile/read.c b/libguile/read.c index 1d7ca78a0..fd5ba4715 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -69,16 +69,9 @@ 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, "positions", 1, @@ -100,47 +93,6 @@ scm_t_option scm_read_opts[] = { 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 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) @@ -179,22 +131,6 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, } #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. */ @@ -233,9 +169,7 @@ scm_i_read_hash_procedures_set_x (SCM value) #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)) + || (((c) == ']' || (c) == '['))) /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical Structure''. */ @@ -246,8 +180,8 @@ scm_i_read_hash_procedures_set_x (SCM value) /* 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_read_commented_expression (scm_t_wchar, SCM); +static SCM scm_read_shebang (scm_t_wchar, SCM); static SCM scm_get_hash_procedure (int); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the @@ -255,8 +189,7 @@ static SCM scm_get_hash_procedure (int); 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_token (SCM port, char *buf, size_t buf_size, size_t *read) { *read = 0; @@ -286,8 +219,7 @@ read_token (SCM port, scm_t_read_opts *opts, /* 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) +read_complete_token (SCM port, char *buffer, size_t buffer_size, size_t *read) { int overflow = 0; size_t bytes_read, overflow_size = 0; @@ -295,7 +227,7 @@ read_complete_token (SCM port, scm_t_read_opts *opts, do { - overflow = read_token (port, opts, buffer, buffer_size, &bytes_read); + overflow = read_token (port, buffer, buffer_size, &bytes_read); if (bytes_read == 0) break; if (overflow || overflow_size != 0) @@ -332,7 +264,7 @@ read_complete_token (SCM port, scm_t_read_opts *opts, /* 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) +flush_ws (SCM port, const char *eoferr) { scm_t_wchar c; while (1) @@ -369,10 +301,10 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) eoferr = "read_sharp"; goto goteof; case '!': - scm_read_shebang (c, port, opts); + scm_read_shebang (c, port); break; case ';': - scm_read_commented_expression (c, port, opts); + scm_read_commented_expression (c, port); break; case '|': if (scm_is_false (scm_get_hash_procedure (c))) @@ -403,60 +335,32 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) /* 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, - SCM line, SCM column); +static SCM scm_read_expression (SCM port); +static SCM scm_read_sharp (int chr, SCM port, SCM line, SCM column); static SCM -maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) -{ - if ((SCM_I_INUMP (line) && SCM_I_INUM (line) < 0) - || (SCM_I_INUMP (column) && SCM_I_INUM (column) < 1)) - /* This condition can be caused by a user calling - set-port-column!. */ - return x; - - if (opts->record_positions_p) - { - /* We always capture the column after one char of lookahead; - subtract off that lookahead value. */ - column = scm_oneminus (column); - 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) +scm_read_sexp (scm_t_wchar chr, SCM port) #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 == '[') ? ']' - : ')')); + const int terminating_char = (chr == '[') ? ']' : ')'; - /* Need to capture line and column numbers here. */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - - c = flush_ws (port, opts, FUNC_NAME); + c = flush_ws (port, FUNC_NAME); if (terminating_char == c) return SCM_EOL; scm_ungetc (c, port); - tmp = scm_read_expression (port, opts); + tmp = scm_read_expression (port); /* 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))) + ans = scm_read_expression (port); + if (terminating_char != (c = flush_ws (port, FUNC_NAME))) scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); return ans; @@ -465,25 +369,24 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) /* Build the head of the list structure. */ ans = tl = scm_cons (tmp, SCM_EOL); - while (terminating_char != (c = flush_ws (port, opts, FUNC_NAME))) + while (terminating_char != (c = flush_ws (port, FUNC_NAME))) { SCM new_tail; - if (c == ')' || (c == ']' && opts->square_brackets_p) - || ((c == '}' || c == ']') && opts->curly_infix_p)) + if (c == ')' || c == ']') 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); + tmp = scm_read_expression (port); /* See above note about scm_sym_dot. */ if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { - SCM_SETCDR (tl, scm_read_expression (port, opts)); + SCM_SETCDR (tl, scm_read_expression (port)); - c = flush_ws (port, opts, FUNC_NAME); + c = flush_ws (port, FUNC_NAME); if (terminating_char != c) scm_i_input_error (FUNC_NAME, port, "in pair: missing close paren", SCM_EOL); @@ -495,60 +398,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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); + return ans; } #undef FUNC_NAME @@ -587,27 +437,11 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } \ } 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) +scm_read_string_like_syntax (int chr, SCM port) #define FUNC_NAME "scm_lreadr" { /* For strings smaller than C_STR, this function creates only one Scheme @@ -617,10 +451,6 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) size_t c_str_len = 0; scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE]; - /* Need to capture line and column numbers here. */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - while (chr != (c = scm_getc (port))) { if (c == EOF) @@ -652,8 +482,6 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) lisp modes. */ break; case '\n': - if (opts->hungry_eol_escapes_p) - skip_intraline_whitespace (port); continue; case '0': c = '\0'; @@ -680,23 +508,14 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) c = '\010'; break; case 'x': - if (opts->r6rs_escapes_p || chr == '|') - SCM_READ_HEX_ESCAPE (10, ';'); - else - SCM_READ_HEX_ESCAPE (2, '\0'); + SCM_READ_HEX_ESCAPE (2, '\0'); break; case 'u': - if (!opts->r6rs_escapes_p) - { - SCM_READ_HEX_ESCAPE (4, '\0'); - break; - } + SCM_READ_HEX_ESCAPE (4, '\0'); + break; case 'U': - if (!opts->r6rs_escapes_p) - { - SCM_READ_HEX_ESCAPE (6, '\0'); - break; - } + SCM_READ_HEX_ESCAPE (6, '\0'); + break; default: if (c == chr) break; @@ -721,35 +540,25 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED); } - return maybe_annotate_source (str, port, opts, line, column); + return str; } #undef FUNC_NAME static SCM -scm_read_string (int chr, SCM port, scm_t_read_opts *opts) +scm_read_string (int chr, SCM port) { - return scm_read_string_like_syntax (chr, port, opts); + return scm_read_string_like_syntax (chr, port); } 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_read_number (scm_t_wchar chr, SCM port) { SCM result, str = SCM_EOL; char local_buffer[READER_BUFFER_SIZE], *buffer; size_t bytes_read; - /* Need to capture line and column numbers here. */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - scm_ungetc (chr, port); - buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, local_buffer, sizeof local_buffer, &bytes_read); str = scm_from_port_stringn (buffer, bytes_read, port); @@ -758,12 +567,8 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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), @@ -772,37 +577,19 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } static SCM -scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) { 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, + buffer = read_complete_token (port, 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); - } + str = scm_from_port_stringn (buffer, bytes_read, port); + result = scm_string_to_symbol (str); scm_set_port_column_x (port, scm_sum (scm_port_column (port), @@ -811,7 +598,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } static SCM -scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_number_and_radix (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { SCM result; @@ -848,7 +635,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) radix = 10; } - buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, local_buffer, sizeof local_buffer, &read); str = scm_from_port_stringn (buffer, read, port); @@ -869,11 +656,9 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #undef FUNC_NAME static SCM -scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) +scm_read_quote (int chr, SCM port) { SCM p; - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); switch (chr) { @@ -906,8 +691,7 @@ scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) abort (); } - p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); - return maybe_annotate_source (p, port, opts, line, column); + return scm_cons2 (p, scm_read_expression (port), SCM_EOL); } SCM_SYMBOL (sym_syntax, "syntax"); @@ -916,11 +700,9 @@ 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_read_syntax (int chr, SCM port) { SCM p; - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); switch (chr) { @@ -953,14 +735,13 @@ scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) abort (); } - p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); - return maybe_annotate_source (p, port, opts, line, column); + return scm_cons2 (p, scm_read_expression (port), SCM_EOL); } static SCM -scm_read_nil (int chr, SCM port, scm_t_read_opts *opts) +scm_read_nil (int chr, SCM port) { - SCM id = scm_read_mixed_case_symbol (chr, port, opts); + SCM id = scm_read_mixed_case_symbol (chr, port); if (!scm_is_eq (id, sym_nil)) scm_i_input_error ("scm_read_nil", port, @@ -1045,7 +826,7 @@ scm_read_boolean (int chr, SCM port) } static SCM -scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_character (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { char buffer[READER_CHAR_NAME_MAX_SIZE]; @@ -1055,7 +836,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) int overflow; scm_t_port *pt; - overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE, + overflow = read_token (port, buffer, READER_CHAR_NAME_MAX_SIZE, &bytes_read); if (overflow) scm_i_input_error (FUNC_NAME, port, "character name too long", SCM_EOL); @@ -1155,7 +936,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #undef FUNC_NAME static SCM -scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts) +scm_read_keyword (int chr, SCM port) { SCM symbol; @@ -1164,7 +945,7 @@ scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts) to adapt to the delimiters currently valid of symbols. XXX: This implementation allows sloppy syntaxes like `#: key'. */ - symbol = scm_read_expression (port, opts); + symbol = scm_read_expression (port); if (!scm_is_symbol (symbol)) scm_i_input_error ("scm_read_keyword", port, "keyword prefix `~a' not followed by a symbol: ~s", @@ -1174,15 +955,13 @@ scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts) } static SCM -scm_read_vector (int chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_vector (int chr, SCM port, SCM line, SCM 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); + return scm_vector (scm_read_sexp (chr, port)); } /* Helper used by scm_read_array */ @@ -1220,19 +999,19 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) C is the first character read after the '#'. */ static SCM -scm_read_array (int c, SCM port, scm_t_read_opts *opts, SCM line, SCM column) +scm_read_array (int c, SCM port, SCM line, SCM column) { ssize_t rank; scm_t_wchar tag_buf[8]; int tag_len; - SCM tag, shape = SCM_BOOL_F, elements, array; + SCM tag, shape = SCM_BOOL_F, elements; /* 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); + return scm_read_vector (c, port, line, column); /* Disambiguate between '#f' and uniform floating point vectors. */ if (c == 'f') @@ -1319,7 +1098,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, SCM line, SCM column) scm_i_input_error (NULL, port, "missing '(' in vector or array literal", SCM_EOL); - elements = scm_read_sexp (c, port, opts); + elements = scm_read_sexp (c, port); if (scm_is_false (shape)) shape = scm_from_ssize_t (rank); @@ -1345,20 +1124,17 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, SCM line, SCM column) } /* 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); + return scm_list_to_typed_array (tag, shape, elements); } static SCM -scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_srfi4_vector (int chr, SCM port, SCM line, SCM column) { - return scm_read_array (chr, port, opts, line, column); + return scm_read_array (chr, port, line, column); } static SCM -scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_bytevector (scm_t_wchar chr, SCM port, SCM line, SCM column) { chr = scm_getc (port); if (chr != 'u') @@ -1372,9 +1148,7 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, if (chr != '(') goto syntax; - return maybe_annotate_source - (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts)), - port, opts, line, column); + return scm_u8_list_to_bytevector (scm_read_sexp (chr, port)); syntax: scm_i_input_error ("read_bytevector", port, @@ -1384,8 +1158,7 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, } static SCM -scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, SCM line, SCM column) { /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is terribly inefficient but who cares? */ @@ -1401,9 +1174,7 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, if (chr != EOF) scm_ungetc (chr, port); - return maybe_annotate_source - (scm_list_to_bitvector (scm_reverse_x (s_bits, SCM_EOL)), - port, opts, line, column); + return scm_list_to_bitvector (scm_reverse_x (s_bits, SCM_EOL)); } static SCM @@ -1430,21 +1201,8 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) 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) +scm_read_shebang (scm_t_wchar chr, SCM port) { char name[READER_DIRECTIVE_NAME_MAX_SIZE + 1]; int c; @@ -1462,29 +1220,15 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { 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; + if (0 == strcmp ("r6rs", name) + || 0 == strcmp ("fold-case", name) + || 0 == strcmp ("no-fold-case", name) + || 0 == strcmp ("curly-infix", name) + || 0 == strcmp ("curly-infix-and-bracket-lists", name)) + scm_i_input_error ("skip_block_comment", port, + "unsupported directive: ~s", + scm_list_1 (scm_from_latin1_string (name))); + break; } else { @@ -1536,17 +1280,16 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) } static SCM -scm_read_commented_expression (scm_t_wchar chr, SCM port, - scm_t_read_opts *opts) +scm_read_commented_expression (scm_t_wchar chr, SCM port) { scm_t_wchar c; - c = flush_ws (port, opts, (char *) NULL); + c = flush_ws (port, (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); + scm_read_expression (port); return SCM_UNSPECIFIED; } @@ -1646,25 +1389,13 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) /* Top-level token readers, i.e., dispatchers. */ static SCM -scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) +scm_read_sharp_extension (int chr, SCM port) { SCM proc; proc = scm_get_hash_procedure (chr); if (scm_is_true (scm_procedure_p (proc))) - { - SCM line = scm_port_line (port); - SCM column = scm_oneminus (scm_port_column (port)); - 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_call_2 (proc, SCM_MAKE_CHAR (chr), port); return SCM_UNSPECIFIED; } @@ -1672,44 +1403,43 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) /* 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, - SCM line, SCM column) +scm_read_sharp (scm_t_wchar chr, SCM port, SCM line, SCM column) #define FUNC_NAME "scm_lreadr" { SCM result; chr = scm_getc (port); - result = scm_read_sharp_extension (chr, port, opts); + result = scm_read_sharp_extension (chr, port); if (!scm_is_eq (result, SCM_UNSPECIFIED)) return result; switch (chr) { case '\\': - return (scm_read_character (chr, port, opts)); + return (scm_read_character (chr, port)); case '(': - return (scm_read_vector (chr, port, opts, line, column)); + return (scm_read_vector (chr, port, 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)); + return (scm_read_srfi4_vector (chr, port, line, column)); case 'v': - return (scm_read_bytevector (chr, port, opts, line, column)); + return (scm_read_bytevector (chr, port, line, column)); case '*': - return (scm_read_guile_bit_vector (chr, port, opts, line, column)); + return (scm_read_guile_bit_vector (chr, port, line, column)); case 't': case 'T': case 'F': return (scm_read_boolean (chr, port)); case ':': - return (scm_read_keyword (chr, port, opts)); + return (scm_read_keyword (chr, port)); 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)); + return (scm_read_array (chr, port, line, column)); case 'i': case 'e': @@ -1723,21 +1453,21 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, case 'X': case 'I': case 'E': - return (scm_read_number_and_radix (chr, port, opts)); + return (scm_read_number_and_radix (chr, port)); case '{': return (scm_read_extended_symbol (chr, port)); case '!': - return (scm_read_shebang (chr, port, opts)); + return (scm_read_shebang (chr, port)); case ';': - return (scm_read_commented_expression (chr, port, opts)); + return (scm_read_commented_expression (chr, port)); case '`': case '\'': case ',': - return (scm_read_syntax (chr, port, opts)); + return (scm_read_syntax (chr, port)); case 'n': - return (scm_read_nil (chr, port, opts)); + return (scm_read_nil (chr, port)); default: - result = scm_read_sharp_extension (chr, port, opts); + result = scm_read_sharp_extension (chr, port); if (scm_is_eq (result, SCM_UNSPECIFIED)) { /* To remain compatible with 1.8 and earlier, the following @@ -1761,8 +1491,8 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, #undef FUNC_NAME static SCM -read_inner_expression (SCM port, scm_t_read_opts *opts) -#define FUNC_NAME "read_inner_expression" +scm_read_expression (SCM port) +#define FUNC_NAME "scm_read_expression" { while (1) { @@ -1776,62 +1506,22 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) case SCM_LINE_INCREMENTORS: break; case ';': - (void) scm_read_semicolon_comment (chr, port); + 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$ ...) */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - 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)); + return scm_read_sexp (chr, port); 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); + return scm_read_string (chr, port); case '\'': case '`': case ',': - return (scm_read_quote (chr, port, opts)); + return scm_read_quote (chr, port); case '#': { SCM line = scm_port_line (port); SCM column = scm_port_column (port); - SCM result = scm_read_sharp (chr, port, opts, line, column); + SCM result = scm_read_sharp (chr, port, line, column); if (scm_is_eq (result, SCM_UNSPECIFIED)) /* We read a comment or some such. */ break; @@ -1841,108 +1531,28 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) 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 */ + scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL); + break; 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)); + return scm_read_number (chr, port); else - return (scm_read_mixed_case_symbol (chr, port, opts)); + return scm_read_mixed_case_symbol (chr, port); } } } } #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 - { - SCM line = SCM_INUM0; - SCM column = SCM_INUM1; - 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; - line = scm_port_line (port); - column = scm_port_column (port); - scm_ungetc (c, 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_primitive_read, "primitive-read", 0, 1, 0, (SCM port), "Read an s-expression from the input port @var{port}, or from\n" @@ -1950,21 +1560,18 @@ SCM_DEFINE (scm_primitive_read, "primitive-read", 0, 1, 0, "Any whitespace before the next token is discarded.") #define FUNC_NAME s_scm_primitive_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); + c = flush_ws (port, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; scm_ungetc (c, port); - return (scm_read_expression (port, &opts)); + return scm_read_expression (port); } #undef FUNC_NAME @@ -1984,6 +1591,22 @@ scm_read (SCM port) +/* 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); +} + /* 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, @@ -2242,163 +1865,6 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0, #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_RECORD_POSITIONS_P 0 -#define READ_OPTION_CASE_INSENSITIVE_P 2 -#define READ_OPTION_KEYWORD_STYLE 4 -#define READ_OPTION_R6RS_ESCAPES_P 6 -#define READ_OPTION_SQUARE_BRACKETS_P 8 -#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 10 -#define READ_OPTION_CURLY_INFIX_P 12 -#define READ_OPTION_R7RS_SYMBOLS_P 14 - -/* The total width in bits of the per-port overrides */ -#define READ_OPTIONS_NUM_BITS 16 - -#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 (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 () |