diff options
author | Andy Wingo <wingo@pobox.com> | 2009-08-25 21:43:00 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-08-25 21:43:00 +0200 |
commit | c6a1380bde978194ee5c533246285f6af4bbb554 (patch) | |
tree | 81bb98421030e83688331b8a12b52bd93de7b403 /libguile/read.c | |
parent | 108e18b18abc066b2709a09283751e9138ccc935 (diff) | |
parent | 889975e51accb80491af76fc5db980aeb3edd342 (diff) | |
download | guile-c6a1380bde978194ee5c533246285f6af4bbb554.tar.gz |
Merge commit 'origin/master'
Conflicts:
libguile/unif.c
Diffstat (limited to 'libguile/read.c')
-rw-r--r-- | libguile/read.c | 383 |
1 files changed, 237 insertions, 146 deletions
diff --git a/libguile/read.c b/libguile/read.c index a8ec0a86d..821e01cea 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -27,6 +27,8 @@ #include <stdio.h> #include <ctype.h> #include <string.h> +#include <unistd.h> +#include <unicase.h> #include "libguile/_scm.h" #include "libguile/bytevectors.h" @@ -178,11 +180,6 @@ static SCM *scm_read_hash_procedures; (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \ || ((_chr) == 'd') || ((_chr) == 'l')) -/* An inlinable version of `scm_c_downcase ()'. */ -#define CHAR_DOWNCASE(_chr) \ - (((_chr) <= UCHAR_MAX) ? tolower ((int) (_chr)) : (_chr)) - - /* Read an SCSH block comment. */ static inline SCM scm_read_scsh_block_comment (int chr, SCM port); static SCM scm_read_commented_expression (int chr, SCM port); @@ -190,41 +187,69 @@ static SCM scm_read_commented_expression (int chr, SCM port); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Return zero if the whole token fits in BUF, non-zero otherwise. */ static inline int -read_token (SCM port, char *buf, size_t buf_size, size_t *read) +read_token (SCM port, SCM buf, size_t *read) { + scm_t_wchar chr; *read = 0; - while (*read < buf_size) + buf = scm_i_string_start_writing (buf); + while (*read < scm_i_string_length (buf)) { - int chr; - chr = scm_getc (port); - chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr); if (chr == EOF) - return 0; - else if (CHAR_IS_DELIMITER (chr)) { - scm_ungetc (chr, port); + scm_i_string_stop_writing (); return 0; } - else + + chr = (SCM_CASE_INSENSITIVE_P ? uc_tolower (chr) : chr); + + if (CHAR_IS_DELIMITER (chr)) { - *buf = (char) chr; - buf++, (*read)++; + scm_i_string_stop_writing (); + scm_ungetc (chr, port); + return 0; } + + scm_i_string_set_x (buf, *read, chr); + (*read)++; } + scm_i_string_stop_writing (); return 1; } +static SCM +read_complete_token (SCM port, size_t *read) +{ + SCM buffer, str = SCM_EOL; + size_t len; + int overflow; + + buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL); + overflow = read_token (port, buffer, read); + if (!overflow) + return scm_i_substring (buffer, 0, *read); + + str = scm_string_copy (buffer); + do + { + overflow = read_token (port, buffer, &len); + str = scm_string_append (scm_list_2 (str, buffer)); + *read += len; + } + while (overflow); + + return scm_i_substring (str, 0, *read); +} /* 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, const char *eoferr) { - register int c; + register scm_t_wchar c; while (1) switch (c = scm_getc (port)) { @@ -293,7 +318,7 @@ static SCM recsexpr (SCM obj, long line, int column, SCM filename); static SCM -scm_read_sexp (int chr, SCM port) +scm_read_sexp (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_i_lreadparen" { register int c; @@ -554,107 +579,52 @@ scm_read_string (int chr, SCM port) static SCM -scm_read_number (int chr, SCM port) +scm_read_number (scm_t_wchar chr, SCM port) { - SCM result, str = SCM_EOL; - char buffer[READER_BUFFER_SIZE]; + SCM result; + SCM buffer; size_t read; - int overflow = 0; scm_ungetc (chr, port); - do - { - overflow = read_token (port, buffer, sizeof (buffer), &read); - - if ((overflow) || (scm_is_pair (str))) - str = scm_cons (scm_from_locale_stringn (buffer, read), str); - } - while (overflow); - - if (scm_is_pair (str)) - { - /* The slow path. */ - - str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); - result = scm_string_to_number (str, SCM_UNDEFINED); - if (!scm_is_true (result)) - /* Return a symbol instead of a number. */ - result = scm_string_to_symbol (str); - } - else - { - result = scm_c_locale_stringn_to_number (buffer, read, 10); - if (!scm_is_true (result)) - /* Return a symbol instead of a number. */ - result = scm_from_locale_symboln (buffer, read); - } + buffer = read_complete_token (port, &read); + result = scm_string_to_number (buffer, SCM_UNDEFINED); + if (!scm_is_true (result)) + /* Return a symbol instead of a number. */ + result = scm_string_to_symbol (buffer); return result; } static SCM -scm_read_mixed_case_symbol (int chr, SCM port) +scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) { - SCM result, str = SCM_EOL; - int overflow = 0, ends_with_colon = 0; - char buffer[READER_BUFFER_SIZE]; + SCM result; + int ends_with_colon = 0; + SCM buffer; size_t read = 0; int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix); scm_ungetc (chr, port); - do - { - overflow = read_token (port, buffer, sizeof (buffer), &read); - - if (read > 0) - ends_with_colon = (buffer[read - 1] == ':'); + buffer = read_complete_token (port, &read); + if (read > 0) + ends_with_colon = scm_i_string_ref (buffer, read - 1) == ':'; - if ((overflow) || (scm_is_pair (str))) - str = scm_cons (scm_from_locale_stringn (buffer, read), str); - } - while (overflow); - - if (scm_is_pair (str)) - { - size_t len; - - str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); - len = scm_c_string_length (str); - - /* Per SRFI-88, `:' alone is an identifier, not a keyword. */ - if (postfix && ends_with_colon && (len > 1)) - { - /* Strip off colon. */ - str = scm_c_substring (str, 0, len-1); - result = scm_string_to_symbol (str); - result = scm_symbol_to_keyword (result); - } - else - result = scm_string_to_symbol (str); - } + if (postfix && ends_with_colon && (read > 1)) + result = scm_symbol_to_keyword (scm_string_to_symbol (scm_i_substring (buffer, 0, read - 1))); else - { - /* For symbols smaller than `sizeof (buffer)', we don't need to recur - to Scheme strings. Therefore, we only create one Scheme object (a - symbol) per symbol read. */ - if (postfix && ends_with_colon && (read > 1)) - result = scm_from_locale_keywordn (buffer, read - 1); - else - result = scm_from_locale_symboln (buffer, read); - } + result = scm_string_to_symbol (buffer); return result; } static SCM -scm_read_number_and_radix (int chr, SCM port) +scm_read_number_and_radix (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { - SCM result, str = SCM_EOL; + SCM result; size_t read; - char buffer[READER_BUFFER_SIZE]; + SCM buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL); unsigned int radix; - int overflow = 0; switch (chr) { @@ -684,22 +654,8 @@ scm_read_number_and_radix (int chr, SCM port) radix = 10; } - do - { - overflow = read_token (port, buffer, sizeof (buffer), &read); - - if ((overflow) || (scm_is_pair (str))) - str = scm_cons (scm_from_locale_stringn (buffer, read), str); - } - while (overflow); - - if (scm_is_pair (str)) - { - str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); - result = scm_string_to_number (str, scm_from_uint (radix)); - } - else - result = scm_c_locale_stringn_to_number (buffer, read, radix); + buffer = read_complete_token (port, &read); + result = scm_string_to_number (buffer, scm_from_uint (radix)); if (scm_is_true (result)) return result; @@ -729,7 +685,7 @@ scm_read_quote (int chr, SCM port) case ',': { - int c; + scm_t_wchar c; c = scm_getc (port); if ('@' == c) @@ -828,7 +784,10 @@ scm_read_semicolon_comment (int chr, SCM port) { int c; - for (c = scm_getc (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); (c != EOF) && (c != '\n'); c = scm_getc (port)); @@ -856,14 +815,19 @@ scm_read_boolean (int chr, SCM port) } static SCM -scm_read_character (int chr, SCM port) +scm_read_character (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { SCM ch; - char charname[READER_CHAR_NAME_MAX_SIZE]; + SCM charname = scm_i_make_string (READER_CHAR_NAME_MAX_SIZE, NULL); size_t charname_len; + scm_t_wchar cp; + int overflow; + + overflow = read_token (port, charname, &charname_len); + charname = scm_c_substring (charname, 0, charname_len); - if (read_token (port, charname, sizeof (charname), &charname_len)) + if (overflow) goto char_error; if (charname_len == 0) @@ -878,28 +842,33 @@ scm_read_character (int chr, SCM port) } if (charname_len == 1) - return SCM_MAKE_CHAR (charname[0]); + return SCM_MAKE_CHAR (scm_i_string_ref (charname, 0)); - if (*charname >= '0' && *charname < '8') + cp = scm_i_string_ref (charname, 0); + 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. Finally, it should be * checked whether the resulting fixnum is in the range of * characters. */ - SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8); + SCM p = scm_string_to_number (charname, scm_from_uint (8)); if (SCM_I_INUMP (p)) return SCM_MAKE_CHAR (SCM_I_INUM (p)); } - ch = scm_i_charname_to_char (charname, charname_len); + /* The names of characters should never have non-Latin1 + characters. */ + if (scm_i_is_narrow_string (charname) + || scm_i_try_narrow_string (charname)) + ch = scm_i_charname_to_char (scm_i_string_chars (charname), + charname_len); if (scm_is_true (ch)) return ch; char_error: scm_i_input_error (FUNC_NAME, port, "unknown character name ~a", - scm_list_1 (scm_from_locale_stringn (charname, - charname_len))); + scm_list_1 (charname)); return SCM_UNSPECIFIED; } @@ -941,7 +910,7 @@ scm_read_srfi4_vector (int chr, SCM port) } static SCM -scm_read_bytevector (int chr, SCM port) +scm_read_bytevector (scm_t_wchar chr, SCM port) { chr = scm_getc (port); if (chr != 'u') @@ -965,7 +934,7 @@ scm_read_bytevector (int chr, SCM port) } static SCM -scm_read_guile_bit_vector (int chr, SCM port) +scm_read_guile_bit_vector (scm_t_wchar chr, SCM port) { /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is terribly inefficient but who cares? */ @@ -985,13 +954,17 @@ scm_read_guile_bit_vector (int chr, SCM port) } static inline SCM -scm_read_scsh_block_comment (int chr, SCM port) +scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) { int bang_seen = 0; + /* We can use the get_byte here because there is no need to get the + locale correct when reading comments. This presumes that + hash and exclamation points always represent themselves no + matter what the source encoding is.*/ for (;;) { - int c = scm_getc (port); + int c = scm_get_byte_or_eof (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, @@ -1009,9 +982,9 @@ scm_read_scsh_block_comment (int chr, SCM port) } static SCM -scm_read_commented_expression (int chr, SCM port) +scm_read_commented_expression (scm_t_wchar chr, SCM port) { - int c; + scm_t_wchar c; c = flush_ws (port, (char *) NULL); if (EOF == c) @@ -1023,19 +996,18 @@ scm_read_commented_expression (int chr, SCM port) } static SCM -scm_read_extended_symbol (int chr, SCM port) +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 `{'. */ - SCM result; int saw_brace = 0, finished = 0; size_t len = 0; - char buf[1024]; + SCM buf = scm_i_make_string (1024, NULL); - result = scm_c_make_string (0, SCM_MAKE_CHAR ('X')); + buf = scm_i_string_start_writing (buf); while ((chr = scm_getc (port)) != EOF) { @@ -1049,32 +1021,30 @@ scm_read_extended_symbol (int chr, SCM port) else { saw_brace = 0; - buf[len++] = '}'; - buf[len++] = chr; + scm_i_string_set_x (buf, len++, '}'); + scm_i_string_set_x (buf, len++, chr); } } else if (chr == '}') saw_brace = 1; else - buf[len++] = chr; + scm_i_string_set_x (buf, len++, chr); - if (len >= sizeof (buf) - 2) + if (len >= scm_i_string_length (buf) - 2) { - scm_string_append (scm_list_2 (result, - scm_from_locale_stringn (buf, len))); + scm_i_string_stop_writing (); + SCM addy = scm_i_make_string (1024, NULL); + buf = scm_string_append (scm_list_2 (buf, addy)); len = 0; + buf = scm_i_string_start_writing (buf); } if (finished) break; } + scm_i_string_stop_writing (); - if (len) - result = scm_string_append (scm_list_2 - (result, - scm_from_locale_stringn (buf, len))); - - return (scm_string_to_symbol (result)); + return (scm_string_to_symbol (scm_c_substring (buf, 0, len))); } @@ -1110,7 +1080,7 @@ scm_read_sharp_extension (int chr, SCM port) /* The reader for the sharp `#' character. It basically dispatches reads among the above token readers. */ static SCM -scm_read_sharp (int chr, SCM port) +scm_read_sharp (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { SCM result; @@ -1162,7 +1132,7 @@ scm_read_sharp (int chr, SCM port) { /* When next char is '(', it really is an old-style uniform array. */ - int next_c = scm_getc (port); + scm_t_wchar next_c = scm_getc (port); if (next_c != EOF) scm_ungetc (next_c, port); if (next_c == '(') @@ -1210,7 +1180,7 @@ scm_read_expression (SCM port) { while (1) { - register int chr; + register scm_t_wchar chr; chr = scm_getc (port); @@ -1421,6 +1391,127 @@ scm_get_hash_procedure (int c) } } +#define SCM_ENCODING_SEARCH_SIZE (500) + +/* Search the first few hundred characters of a file for + an emacs-like coding declaration. */ +char * +scm_scan_for_encoding (SCM port) +{ + char header[SCM_ENCODING_SEARCH_SIZE+1]; + size_t bytes_read; + char *encoding = NULL; + int utf8_bom = 0; + char *pos; + int i; + int in_comment; + + bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE); + scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET)); + + if (bytes_read > 3 + && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf') + utf8_bom = 1; + + /* 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 ++; + + /* grab the next token */ + i = 0; + while (pos + i - header <= SCM_ENCODING_SEARCH_SIZE + && (isalnum(pos[i]) || pos[i] == '_' || pos[i] == '-' || pos[i] == '.')) + i++; + + if (i == 0) + return NULL; + + encoding = scm_malloc (i+1); + memcpy (encoding, pos, i); + encoding[i] ='\0'; + for (i = 0; i < strlen(encoding); i++) + encoding[i] = toupper(encoding[i]); + + /* push backwards to make sure we were in a comment */ + in_comment = 0; + while (pos - i - header > 0) + { + if (*(pos - i) == '\n') + { + /* This wasn't in a semicolon comment. Check for a + hash-bang comment. */ + char *beg = strstr (header, "#!"); + char *end = strstr (header, "!#"); + if (beg < pos && pos < end) + in_comment = 1; + break; + } + if (*(pos - i) == ';') + { + in_comment = 1; + break; + } + i ++; + } + if (!in_comment) + { + /* This wasn't in a comment */ + free (encoding); + return NULL; + } + if (utf8_bom && strcmp(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))); + + 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-acessible 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; + + enc = scm_scan_for_encoding (port); + if (enc == NULL) + return SCM_BOOL_F; + else + { + s_enc = scm_from_locale_string (enc); + free (enc); + return s_enc; + } + + return SCM_BOOL_F; +} +#undef FUNC_NAME + void scm_init_read () { |