diff options
Diffstat (limited to 'libguile/read.c')
-rw-r--r-- | libguile/read.c | 195 |
1 files changed, 86 insertions, 109 deletions
diff --git a/libguile/read.c b/libguile/read.c index 222891b7f..7c003b4e1 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -25,7 +25,6 @@ #endif #include <stdio.h> -#include <ctype.h> #include <string.h> #include <unistd.h> #include <unicase.h> @@ -258,13 +257,13 @@ read_token (SCM port, scm_t_read_opts *opts, { int chr; - chr = scm_get_byte_or_eof (port); + chr = scm_get_byte_or_eof_unlocked (port); if (chr == EOF) return 0; else if (CHAR_IS_DELIMITER (chr)) { - scm_unget_byte (chr, port); + scm_unget_byte_unlocked (chr, port); return 0; } else @@ -330,7 +329,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) { scm_t_wchar c; while (1) - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: goteof: @@ -345,7 +344,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) case ';': lp: - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: goto goteof; @@ -357,7 +356,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) break; case '#': - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: eoferr = "read_sharp"; @@ -376,7 +375,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) } /* fall through */ default: - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); return '#'; } break; @@ -430,7 +429,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) if (terminating_char == c) return SCM_EOL; - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); tmp = scm_read_expression (port, opts); /* Note that it is possible for scm_read_expression to return @@ -458,7 +457,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) "in pair: mismatched close paren: ~A", scm_list_1 (SCM_MAKE_CHAR (c))); - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); tmp = scm_read_expression (port, opts); /* See above note about scm_sym_dot. */ @@ -547,7 +546,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) c = 0; \ while (i < ndigits) \ { \ - a = scm_getc (port); \ + a = scm_getc_unlocked (port); \ if (a == EOF) \ goto str_eof; \ if (terminator \ @@ -577,13 +576,13 @@ skip_intraline_whitespace (SCM port) do { - c = scm_getc (port); + c = scm_getc_unlocked (port); if (c == EOF) return; } while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR)); - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); } static SCM @@ -601,7 +600,7 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - while ('"' != (c = scm_getc (port))) + while ('"' != (c = scm_getc_unlocked (port))) { if (c == EOF) { @@ -618,7 +617,7 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) if (c == '\\') { - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: goto str_eof; @@ -704,17 +703,16 @@ 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; - scm_t_port *pt = SCM_PTAB_ENTRY (port); /* Need to capture line and column numbers here. */ long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - scm_ungetc (chr, port); + scm_ungetc_unlocked (chr, port); buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &bytes_read); - str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler); + str = scm_from_port_stringn (buffer, bytes_read, port); result = scm_string_to_number (str, SCM_UNDEFINED); if (scm_is_false (result)) @@ -739,10 +737,9 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) size_t bytes_read; int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX); char local_buffer[READER_BUFFER_SIZE], *buffer; - scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM str; - scm_ungetc (chr, port); + scm_ungetc_unlocked (chr, port); buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &bytes_read); if (bytes_read > 0) @@ -750,8 +747,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) if (postfix && ends_with_colon && (bytes_read > 1)) { - str = scm_from_stringn (buffer, bytes_read - 1, - pt->encoding, pt->ilseq_handler); + str = scm_from_port_stringn (buffer, bytes_read - 1, port); if (opts->case_insensitive_p) str = scm_string_downcase_x (str); @@ -759,8 +755,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } else { - str = scm_from_stringn (buffer, bytes_read, - pt->encoding, pt->ilseq_handler); + str = scm_from_port_stringn (buffer, bytes_read, port); if (opts->case_insensitive_p) str = scm_string_downcase_x (str); @@ -780,7 +775,6 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) char local_buffer[READER_BUFFER_SIZE], *buffer; unsigned int radix; SCM str; - scm_t_port *pt; switch (chr) { @@ -805,16 +799,15 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) break; default: - scm_ungetc (chr, port); - scm_ungetc ('#', port); + scm_ungetc_unlocked (chr, port); + scm_ungetc_unlocked ('#', port); radix = 10; } buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &read); - pt = SCM_PTAB_ENTRY (port); - str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler); + str = scm_from_port_stringn (buffer, read, port); result = scm_string_to_number (str, scm_from_uint (radix)); @@ -850,12 +843,12 @@ scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) { scm_t_wchar c; - c = scm_getc (port); + c = scm_getc_unlocked (port); if ('@' == c) p = scm_sym_uq_splicing; else { - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); p = scm_sym_unquote; } break; @@ -897,12 +890,12 @@ scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) { int c; - c = scm_getc (port); + c = scm_getc_unlocked (port); if ('@' == c) p = sym_unsyntax_splicing; else { - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); p = sym_unsyntax; } break; @@ -939,9 +932,9 @@ scm_read_semicolon_comment (int chr, SCM port) /* 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); + for (c = scm_get_byte_or_eof_unlocked (port); (c != EOF) && (c != '\n'); - c = scm_get_byte_or_eof (port)); + c = scm_get_byte_or_eof_unlocked (port)); return SCM_UNSPECIFIED; } @@ -984,7 +977,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) if (bytes_read == 0) { - chr = scm_getc (port); + chr = scm_getc_unlocked (port); if (chr == EOF) scm_i_input_error (FUNC_NAME, port, "unexpected end of file " "while reading character", SCM_EOL); @@ -998,7 +991,9 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) /* 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 || pt->encoding == NULL)) + if (bytes_read == 1 && + ((unsigned char) buffer[0] <= 127 + || pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)) { SCM_COL (port) += 1; return SCM_MAKE_CHAR (buffer[0]); @@ -1006,8 +1001,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) /* Otherwise, convert the buffer into a proper scheme string for processing. */ - charname = scm_from_stringn (buffer, bytes_read, pt->encoding, - pt->ilseq_handler); + charname = scm_from_port_stringn (buffer, bytes_read, port); charname_len = scm_i_string_length (charname); SCM_COL (port) += charname_len; cp = scm_i_string_ref (charname, 0); @@ -1115,14 +1109,14 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) if (c == '-') { sign = -1; - c = scm_getc (port); + c = scm_getc_unlocked (port); } while ('0' <= c && c <= '9') { res = 10*res + c-'0'; got_it = 1; - c = scm_getc (port); + c = scm_getc_unlocked (port); } if (got_it) @@ -1153,11 +1147,11 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) /* Disambiguate between '#f' and uniform floating point vectors. */ if (c == 'f') { - c = scm_getc (port); + c = scm_getc_unlocked (port); if (c != '3' && c != '6') { if (c != EOF) - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); return SCM_BOOL_F; } rank = 1; @@ -1180,7 +1174,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) && tag_len < sizeof tag_buf / sizeof tag_buf[0]) { tag_buf[tag_len++] = c; - c = scm_getc (port); + c = scm_getc_unlocked (port); } if (tag_len == 0) tag = SCM_BOOL_T; @@ -1204,7 +1198,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) if (c == '@') { - c = scm_getc (port); + c = scm_getc_unlocked (port); c = read_decimal_integer (port, c, &lbnd); } @@ -1212,7 +1206,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) if (c == ':') { - c = scm_getc (port); + c = scm_getc_unlocked (port); c = read_decimal_integer (port, c, &len); if (len < 0) scm_i_input_error (NULL, port, @@ -1274,15 +1268,15 @@ static SCM scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, long line, int column) { - chr = scm_getc (port); + chr = scm_getc_unlocked (port); if (chr != 'u') goto syntax; - chr = scm_getc (port); + chr = scm_getc_unlocked (port); if (chr != '8') goto syntax; - chr = scm_getc (port); + chr = scm_getc_unlocked (port); if (chr != '(') goto syntax; @@ -1305,15 +1299,15 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, terribly inefficient but who cares? */ SCM s_bits = SCM_EOL; - for (chr = scm_getc (port); + for (chr = scm_getc_unlocked (port); (chr != EOF) && ((chr == '0') || (chr == '1')); - chr = scm_getc (port)) + chr = scm_getc_unlocked (port)) { s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits); } if (chr != EOF) - scm_ungetc (chr, port); + scm_ungetc_unlocked (chr, port); return maybe_annotate_source (scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)), @@ -1327,7 +1321,7 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) for (;;) { - int c = scm_getc (port); + int c = scm_getc_unlocked (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, @@ -1360,7 +1354,7 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) while (i <= READER_DIRECTIVE_NAME_MAX_SIZE) { - c = scm_getc (port); + c = scm_getc_unlocked (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, "unterminated `#! ... !#' comment", SCM_EOL); @@ -1368,7 +1362,7 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) name[i++] = c; else if (CHAR_IS_DELIMITER (c)) { - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); name[i] = '\0'; if (0 == strcmp ("r6rs", name)) ; /* Silently ignore */ @@ -1390,12 +1384,12 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } else { - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); break; } } while (i > 0) - scm_ungetc (name[--i], port); + scm_ungetc_unlocked (name[--i], port); return scm_read_scsh_block_comment (chr, port); } @@ -1406,7 +1400,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) nested. So care must be taken. */ int nesting_level = 1; - int a = scm_getc (port); + int a = scm_getc_unlocked (port); if (a == EOF) scm_i_input_error ("scm_read_r6rs_block_comment", port, @@ -1414,7 +1408,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) while (nesting_level > 0) { - int b = scm_getc (port); + int b = scm_getc_unlocked (port); if (b == EOF) scm_i_input_error ("scm_read_r6rs_block_comment", port, @@ -1447,7 +1441,7 @@ scm_read_commented_expression (scm_t_wchar chr, SCM port, if (EOF == c) scm_i_input_error ("read_commented_expression", port, "no expression after #; comment", SCM_EOL); - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); scm_read_expression (port, opts); return SCM_UNSPECIFIED; } @@ -1466,7 +1460,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) buf = scm_i_string_start_writing (buf); - while ((chr = scm_getc (port)) != EOF) + while ((chr = scm_getc_unlocked (port)) != EOF) { if (saw_brace) { @@ -1493,7 +1487,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) 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))) + switch ((chr = scm_getc_unlocked (port))) { case EOF: goto done; @@ -1582,7 +1576,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, { SCM result; - chr = scm_getc (port); + chr = scm_getc_unlocked (port); result = scm_read_sharp_extension (chr, port, opts); if (!scm_is_eq (result, SCM_UNSPECIFIED)) @@ -1613,29 +1607,10 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '@': -#if SCM_ENABLE_DEPRECATED - /* See below for 'i' and 'e'. */ - case 'a': - case 'y': - case 'h': - case 'l': -#endif return (scm_read_array (chr, port, opts, line, column)); case 'i': case 'e': -#if SCM_ENABLE_DEPRECATED - { - /* When next char is '(', it really is an old-style - uniform array. */ - scm_t_wchar next_c = scm_getc (port); - if (next_c != EOF) - scm_ungetc (next_c, port); - if (next_c == '(') - return scm_read_array (chr, port, opts, line, column); - /* Fall through. */ - } -#endif case 'b': case 'B': case 'o': @@ -1691,7 +1666,7 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) { scm_t_wchar chr; - chr = scm_getc (port); + chr = scm_getc_unlocked (port); switch (chr) { @@ -1811,7 +1786,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) int c = flush_ws (port, opts, (char *) NULL); if (c == EOF) return SCM_EOF_VAL; - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); line = SCM_LINUM (port); column = SCM_COL (port); } @@ -1824,7 +1799,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */ for (;;) { - int chr = scm_getc (port); + int chr = scm_getc_unlocked (port); if (chr == '(') /* e(...) => (e ...) */ @@ -1846,7 +1821,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) else { if (chr != EOF) - scm_ungetc (chr, port); + scm_ungetc_unlocked (chr, port); break; } maybe_annotate_source (expr, port, opts, line, column); @@ -1880,7 +1855,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, c = flush_ws (port, &opts, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); return (scm_read_expression (port, &opts)); } @@ -1975,6 +1950,15 @@ scm_get_hash_procedure (int c) #define SCM_ENCODING_SEARCH_SIZE (500) +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; +} + /* Search the first few hundred characters of a file for an Emacs-like coding declaration. Returns either NULL or a string whose storage has been allocated with `scm_gc_malloc ()'. */ @@ -1992,7 +1976,7 @@ scm_i_scan_for_encoding (SCM port) pt = SCM_PTAB_ENTRY (port); if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (port); + scm_flush_unlocked (port); if (pt->rw_random) pt->rw_active = SCM_PORT_READ; @@ -2000,7 +1984,7 @@ scm_i_scan_for_encoding (SCM port) if (pt->read_pos == pt->read_end) { /* We can use the read buffer, and thus avoid a seek. */ - if (scm_fill_input (port) == EOF) + if (scm_fill_input_unlocked (port) == EOF) return NULL; bytes_read = pt->read_end - pt->read_pos; @@ -2025,7 +2009,7 @@ scm_i_scan_for_encoding (SCM port) if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port))) return NULL; - bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE); + bytes_read = scm_c_read_unlocked (port, header, SCM_ENCODING_SEARCH_SIZE); header[bytes_read] = '\0'; scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET)); } @@ -2060,8 +2044,7 @@ scm_i_scan_for_encoding (SCM port) i = 0; while (encoding_start + i - header <= SCM_ENCODING_SEARCH_SIZE && encoding_start + i - header < bytes_read - && (isalnum ((int) encoding_start[i]) - || strchr ("_-.:/,+=()", encoding_start[i]) != NULL)) + && is_encoding_char (encoding_start[i])) i++; encoding_length = i; @@ -2069,8 +2052,6 @@ scm_i_scan_for_encoding (SCM port) return NULL; encoding = scm_gc_strndup (encoding_start, encoding_length, "encoding"); - for (i = 0; i < encoding_length; i++) - encoding[i] = toupper ((int) encoding[i]); /* push backwards to make sure we were in a comment */ in_comment = 0; @@ -2102,7 +2083,7 @@ scm_i_scan_for_encoding (SCM port) /* This wasn't in a comment */ return NULL; - if (utf8_bom && strcmp(encoding, "UTF-8")) + if (utf8_bom && strcasecmp (encoding, "UTF-8")) scm_misc_error (NULL, "the port input declares the encoding ~s but is encoded as UTF-8", scm_list_1 (scm_from_locale_string (encoding))); @@ -2143,9 +2124,8 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0, /* Per-port read options. We store per-port read options in the 'port-read-options' key of the - port's alist, which is stored in 'scm_i_port_weak_hash'. The value - stored in the alist is a single integer that contains a two-bit field - for each read option. + port's alist. The value stored in the alist 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 @@ -2180,13 +2160,12 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options"); static void set_port_read_option (SCM port, int option, int new_value) { - SCM alist, scm_read_options; + SCM scm_read_options; unsigned int read_options; new_value &= READ_OPTION_MASK; - scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); - alist = scm_hashq_ref (scm_i_port_weak_hash, port, SCM_BOOL_F); - scm_read_options = scm_assq_ref (alist, sym_port_read_options); + scm_read_options = scm_assq_ref (SCM_PTAB_ENTRY(port)->alist, + 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 @@ -2194,9 +2173,9 @@ set_port_read_option (SCM port, int option, int new_value) read_options &= ~(READ_OPTION_MASK << option); read_options |= new_value << option; scm_read_options = scm_from_uint (read_options); - alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options); - scm_hashq_set_x (scm_i_port_weak_hash, port, alist); - scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + SCM_PTAB_ENTRY(port)->alist = scm_assq_set_x (SCM_PTAB_ENTRY(port)->alist, + sym_port_read_options, + scm_read_options); } /* Set OPTS and PORT's case-insensitivity according to VALUE. */ @@ -2231,13 +2210,11 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value) static void init_read_options (SCM port, scm_t_read_opts *opts) { - SCM alist, val, scm_read_options; + SCM val, scm_read_options; unsigned int read_options, x; - scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); - alist = scm_hashq_ref (scm_i_port_weak_hash, port, SCM_BOOL_F); - scm_read_options = scm_assq_ref (alist, sym_port_read_options); - scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + scm_read_options = scm_assq_ref (SCM_PTAB_ENTRY(port)->alist, + 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); |