summaryrefslogtreecommitdiff
path: root/libguile/read.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-08-25 21:43:00 +0200
committerAndy Wingo <wingo@pobox.com>2009-08-25 21:43:00 +0200
commitc6a1380bde978194ee5c533246285f6af4bbb554 (patch)
tree81bb98421030e83688331b8a12b52bd93de7b403 /libguile/read.c
parent108e18b18abc066b2709a09283751e9138ccc935 (diff)
parent889975e51accb80491af76fc5db980aeb3edd342 (diff)
downloadguile-c6a1380bde978194ee5c533246285f6af4bbb554.tar.gz
Merge commit 'origin/master'
Conflicts: libguile/unif.c
Diffstat (limited to 'libguile/read.c')
-rw-r--r--libguile/read.c383
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 ()
{