-/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software
- * Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include <string.h>
#include <unistd.h>
#include <unicase.h>
+#include <unictype.h>
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
scm_t_option scm_read_opts[] = {
{ SCM_OPTION_BOOLEAN, "copy", 0,
"Copy source code expressions." },
- { SCM_OPTION_BOOLEAN, "positions", 0,
+ { SCM_OPTION_BOOLEAN, "positions", 1,
"Record positions of source code expressions." },
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0,
"Convert symbols to lower case."},
- { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F,
+ { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
"Style of keyword recognition: #f, 'prefix or 'postfix."},
{ SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
"Use R6RS variable-length character and string hex escapes."},
{ SCM_OPTION_BOOLEAN, "square-brackets", 1,
"Treat `[' and `]' as parentheses, for R6RS compatibility."},
+ { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0,
+ "In strings, consume leading whitespace after an escaped end-of-line."},
{ 0, },
};
characters to procedures. */
static SCM *scm_i_read_hash_procedures;
-static inline SCM
+static SCM
scm_i_read_hash_procedures_ref (void)
{
return scm_fluid_ref (*scm_i_read_hash_procedures);
}
-static inline void
+static void
scm_i_read_hash_procedures_set_x (SCM value)
{
scm_fluid_set_x (*scm_i_read_hash_procedures, value);
/* Size of the C buffer used to read symbols and numbers. */
#define READER_BUFFER_SIZE 128
-/* Size of the C buffer used to read strings. */
-#define READER_STRING_BUFFER_SIZE 512
+/* Number of 32-bit codepoints in the buffer used to read strings. */
+#define READER_STRING_BUFFER_SIZE 128
/* The maximum size of Scheme character names. */
#define READER_CHAR_NAME_MAX_SIZE 50
|| ((_chr) == 'd') || ((_chr) == 'l'))
/* Read an SCSH block comment. */
-static inline SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
+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);
static SCM scm_read_shebang (scm_t_wchar, SCM);
result in the pre-allocated buffer BUF. Return zero if the whole token has
fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number of
bytes actually read. */
-static inline int
-read_token (SCM port, char *buf, const size_t buf_size, size_t *read)
- {
+static int
+read_token (SCM port, char *buf, size_t buf_size, size_t *read)
+{
*read = 0;
while (*read < buf_size)
return 1;
}
-/* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the
- result in the pre-allocated buffer BUFFER, if the whole token has fewer than
- BUFFER_SIZE bytes, or into OVERFLOW_BUFFER, allocated here to be freed by the
- caller. Return zero if the token fits in BUFFER, non-zero otherwise. READ
- will be set the number of bytes actually read. */
-static int
-read_complete_token (SCM port, char *buffer, const size_t buffer_size,
- char **overflow_buffer, size_t *read)
+/* 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, char *buffer, size_t buffer_size,
+ size_t *read)
{
int overflow = 0;
- size_t bytes_read, overflow_size;
-
- *overflow_buffer = NULL;
- overflow_size = 0;
+ size_t bytes_read, overflow_size = 0;
+ char *overflow_buffer = NULL;
do
{
{
if (overflow_size == 0)
{
- *overflow_buffer = scm_malloc (bytes_read);
- memcpy (*overflow_buffer, buffer, bytes_read);
+ overflow_buffer = scm_gc_malloc_pointerless (bytes_read, "read");
+ memcpy (overflow_buffer, buffer, bytes_read);
overflow_size = bytes_read;
}
else
{
- *overflow_buffer = scm_realloc (*overflow_buffer, overflow_size + bytes_read);
- memcpy (*overflow_buffer + overflow_size, buffer, bytes_read);
+ char *new_buf =
+ scm_gc_malloc_pointerless (overflow_size + bytes_read, "read");
+
+ memcpy (new_buf, overflow_buffer, overflow_size);
+ memcpy (new_buf + overflow_size, buffer, bytes_read);
+
+ overflow_buffer = new_buf;
overflow_size += bytes_read;
}
}
else
*read = bytes_read;
- return (overflow_size != 0);
+ return (overflow_size > 0 ? overflow_buffer : buffer);
}
/* Skip whitespace from PORT and return the first non-whitespace character
static int
flush_ws (SCM port, const char *eoferr)
{
- register scm_t_wchar c;
+ scm_t_wchar c;
while (1)
switch (c = scm_getc (port))
{
/* Token readers. */
static SCM scm_read_expression (SCM port);
-static SCM scm_read_sharp (int chr, SCM port);
-static SCM recsexpr (SCM obj, long line, int column, SCM filename);
+static SCM scm_read_sharp (int chr, SCM port, long line, int column);
+static SCM
+maybe_annotate_source (SCM x, SCM port, long line, int column)
+{
+ if (SCM_RECORD_POSITIONS_P)
+ scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port));
+ return x;
+}
+
static SCM
scm_read_sexp (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_i_lreadparen"
{
- register int c;
- register SCM tmp;
- register SCM tl, ans = SCM_EOL;
- SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
+ int c;
+ SCM tmp, tl, ans = SCM_EOL;
const int terminating_char = ((chr == '[') ? ']' : ')');
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
-
c = flush_ws (port, FUNC_NAME);
if (terminating_char == c)
return SCM_EOL;
scm_ungetc (c, port);
- if (scm_is_eq (scm_sym_dot,
- (tmp = scm_read_expression (port))))
+ 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);
if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
/* Build the head of the list structure. */
ans = tl = scm_cons (tmp, SCM_EOL);
- if (SCM_COPY_SOURCE_P)
- ans2 = tl2 = scm_cons (scm_is_pair (tmp)
- ? copy
- : tmp,
- SCM_EOL);
-
while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
{
SCM new_tail;
scm_ungetc (c, port);
tmp = scm_read_expression (port);
- if (scm_is_eq (scm_sym_dot, tmp))
+ /* See above note about scm_sym_dot. */
+ if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
{
- SCM_SETCDR (tl, tmp = scm_read_expression (port));
-
- if (SCM_COPY_SOURCE_P)
- SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
- SCM_EOL));
+ SCM_SETCDR (tl, scm_read_expression (port));
c = flush_ws (port, FUNC_NAME);
if (terminating_char != c)
new_tail = scm_cons (tmp, SCM_EOL);
SCM_SETCDR (tl, new_tail);
tl = new_tail;
-
- if (SCM_COPY_SOURCE_P)
- {
- SCM new_tail2 = scm_cons (scm_is_pair (tmp)
- ? copy
- : tmp, SCM_EOL);
- SCM_SETCDR (tl2, new_tail2);
- tl2 = new_tail2;
- }
}
exit:
- if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash,
- ans,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? ans2
- : SCM_UNDEFINED,
- SCM_EOL));
- return ans;
+ return maybe_annotate_source (ans, port, line, column);
}
#undef FUNC_NAME
} \
} 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);
+}
+
static SCM
scm_read_string (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
/* For strings smaller than C_STR, this function creates only one Scheme
object (the string returned). */
- SCM str = SCM_BOOL_F;
- unsigned c_str_len = 0;
- scm_t_wchar c;
+ SCM str = SCM_EOL;
+ size_t c_str_len = 0;
+ scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE];
+
+ /* Need to capture line and column numbers here. */
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
- str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
while ('"' != (c = scm_getc (port)))
{
if (c == EOF)
"end of file in string constant", SCM_EOL);
}
- if (c_str_len + 1 >= scm_i_string_length (str))
- {
- SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
-
- str = scm_string_append (scm_list_2 (str, addy));
- }
+ if (c_str_len + 1 >= READER_STRING_BUFFER_SIZE)
+ {
+ str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
+ c_str_len = 0;
+ }
if (c == '\\')
{
case '\\':
break;
case '\n':
+ if (SCM_HUNGRY_EOL_ESCAPES_P)
+ skip_intraline_whitespace (port);
continue;
case '0':
c = '\0';
scm_list_1 (SCM_MAKE_CHAR (c)));
}
}
- str = scm_i_string_start_writing (str);
- scm_i_string_set_x (str, c_str_len++, c);
- scm_i_string_stop_writing ();
+
+ c_str[c_str_len++] = c;
}
- if (c_str_len > 0)
+ if (scm_is_null (str))
+ /* Fast path: we got a string that fits in C_STR. */
+ str = scm_from_utf32_stringn (c_str, c_str_len);
+ else
{
- return scm_i_substring_copy (str, 0, c_str_len);
+ if (c_str_len > 0)
+ str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
+
+ str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED);
}
- return scm_nullstr;
+ return maybe_annotate_source (str, port, line, column);
}
#undef FUNC_NAME
scm_read_number (scm_t_wchar chr, SCM port)
{
SCM result, str = SCM_EOL;
- char buffer[READER_BUFFER_SIZE];
- char *overflow_buffer = NULL;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
size_t bytes_read;
- int overflow;
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);
- overflow = read_complete_token (port, buffer, sizeof (buffer),
- &overflow_buffer, &bytes_read);
+ buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ &bytes_read);
- if (!overflow)
- str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, bytes_read, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
result = scm_string_to_number (str, SCM_UNDEFINED);
- if (!scm_is_true (result))
+ if (scm_is_false (result))
{
/* Return a symbol instead of a number */
if (SCM_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, line, column);
- if (overflow)
- free (overflow_buffer);
SCM_COL (port) += scm_i_string_length (str);
return result;
}
int ends_with_colon = 0;
size_t bytes_read;
int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
- int overflow;
- char buffer[READER_BUFFER_SIZE], *overflow_buffer;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
scm_ungetc (chr, port);
- overflow = read_complete_token (port, buffer, READER_BUFFER_SIZE,
- &overflow_buffer, &bytes_read);
+ buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ &bytes_read);
if (bytes_read > 0)
- {
- if (!overflow)
- ends_with_colon = buffer[bytes_read - 1] == ':';
- else
- ends_with_colon = overflow_buffer[bytes_read - 1] == ':';
- }
+ ends_with_colon = buffer[bytes_read - 1] == ':';
if (postfix && ends_with_colon && (bytes_read > 1))
{
- if (!overflow)
- str = scm_from_stringn (buffer, bytes_read - 1, pt->encoding, pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, bytes_read - 1, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, bytes_read - 1,
+ pt->encoding, pt->ilseq_handler);
if (SCM_CASE_INSENSITIVE_P)
str = scm_string_downcase_x (str);
}
else
{
- if (!overflow)
- str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, bytes_read, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, bytes_read,
+ pt->encoding, pt->ilseq_handler);
if (SCM_CASE_INSENSITIVE_P)
str = scm_string_downcase_x (str);
result = scm_string_to_symbol (str);
}
- if (overflow)
- free (overflow_buffer);
SCM_COL (port) += scm_i_string_length (str);
return result;
}
{
SCM result;
size_t read;
- char buffer[READER_BUFFER_SIZE], *overflow_buffer;
- int overflow;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
unsigned int radix;
SCM str;
scm_t_port *pt;
radix = 10;
}
- overflow = read_complete_token (port, buffer, sizeof (buffer),
- &overflow_buffer, &read);
+ buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ &read);
pt = SCM_PTAB_ENTRY (port);
- if (!overflow)
- str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, read, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler);
result = scm_string_to_number (str, scm_from_uint (radix));
- if (overflow)
- free (overflow_buffer);
-
SCM_COL (port) += scm_i_string_length (str);
if (scm_is_true (result))
}
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
- if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
-
-
- return p;
+ return maybe_annotate_source (p, port, line, column);
}
SCM_SYMBOL (sym_syntax, "syntax");
}
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
- if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash, p,
- scm_make_srcprops (line, column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
-
-
- return p;
+ return maybe_annotate_source (p, port, line, column);
}
-static inline SCM
+static SCM
scm_read_nil (int chr, SCM port)
{
SCM id = scm_read_mixed_case_symbol (chr, port);
return SCM_ELISP_NIL;
}
-static inline SCM
+static SCM
scm_read_semicolon_comment (int chr, SCM port)
{
int c;
}
#undef FUNC_NAME
-static inline SCM
+static SCM
scm_read_keyword (int chr, SCM port)
{
SCM symbol;
return (scm_symbol_to_keyword (symbol));
}
-static inline SCM
-scm_read_vector (int chr, SCM port)
+static SCM
+scm_read_vector (int chr, SCM port, long line, int column)
{
/* Note: We call `scm_read_sexp ()' rather than READER here in order to
guarantee that it's going to do what we want. After all, this is an
implementation detail of `scm_read_vector ()', not a desirable
property. */
- return (scm_vector (scm_read_sexp (chr, port)));
+ return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port)),
+ port, line, column);
+}
+
+static SCM
+scm_read_array (int chr, SCM port, long line, int column)
+{
+ SCM result = scm_i_read_array (port, chr);
+ if (scm_is_false (result))
+ return result;
+ else
+ return maybe_annotate_source (result, port, line, column);
}
-static inline SCM
-scm_read_srfi4_vector (int chr, SCM port)
+static SCM
+scm_read_srfi4_vector (int chr, SCM port, long line, int column)
{
- return scm_i_read_array (port, chr);
+ return scm_read_array (chr, port, line, column);
}
static SCM
-scm_read_bytevector (scm_t_wchar chr, SCM port)
+scm_read_bytevector (scm_t_wchar chr, SCM port, long line, int column)
{
chr = scm_getc (port);
if (chr != 'u')
if (chr != '(')
goto syntax;
- return scm_u8_list_to_bytevector (scm_read_sexp (chr, port));
+ return maybe_annotate_source
+ (scm_u8_list_to_bytevector (scm_read_sexp (chr, port)),
+ port, line, column);
syntax:
scm_i_input_error ("read_bytevector", port,
}
static SCM
-scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
+scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, long line, int column)
{
/* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
terribly inefficient but who cares? */
if (chr != EOF)
scm_ungetc (chr, port);
- return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
+ return maybe_annotate_source
+ (scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)),
+ port, line, column);
}
-static inline SCM
+static SCM
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_get_byte_or_eof (port);
+ int c = scm_getc (port);
if (c == EOF)
scm_i_input_error ("skip_block_comment", port,
return SCM_UNSPECIFIED;
}
-static inline SCM
+static SCM
scm_read_shebang (scm_t_wchar chr, SCM port)
{
int c = 0;
/* Unlike SCSH-style block comments, SRFI-30/R6RS block comments may be
nested. So care must be taken. */
int nesting_level = 1;
- int opening_seen = 0, closing_seen = 0;
+
+ int a = scm_getc (port);
+
+ if (a == EOF)
+ scm_i_input_error ("scm_read_r6rs_block_comment", port,
+ "unterminated `#| ... |#' comment", SCM_EOL);
while (nesting_level > 0)
{
- int c = scm_getc (port);
+ int b = scm_getc (port);
- if (c == EOF)
+ if (b == EOF)
scm_i_input_error ("scm_read_r6rs_block_comment", port,
"unterminated `#| ... |#' comment", SCM_EOL);
- if (opening_seen)
- {
- if (c == '|')
- nesting_level++;
- opening_seen = 0;
- }
- else if (closing_seen)
- {
- if (c == '#')
- nesting_level--;
- closing_seen = 0;
- }
- else if (c == '|')
- closing_seen = 1;
- else if (c == '#')
- opening_seen = 1;
- else
- opening_seen = closing_seen = 0;
+ if (a == '|' && b == '#')
+ {
+ nesting_level--;
+ b = EOF;
+ }
+ else if (a == '#' && b == '|')
+ {
+ nesting_level++;
+ b = EOF;
+ }
+
+ a = b;
}
return SCM_UNSPECIFIED;
#{This is all a symbol name}#
So here, CHR is expected to be `{'. */
- int saw_brace = 0, finished = 0;
+ int saw_brace = 0;
size_t len = 0;
- SCM buf = scm_i_make_string (1024, NULL);
+ SCM buf = scm_i_make_string (1024, NULL, 0);
buf = scm_i_string_start_writing (buf);
{
if (chr == '#')
{
- finished = 1;
break;
}
else
{
saw_brace = 0;
scm_i_string_set_x (buf, len++, '}');
- scm_i_string_set_x (buf, len++, chr);
}
}
- else if (chr == '}')
+
+ if (chr == '}')
saw_brace = 1;
+ else if (chr == '\\')
+ {
+ /* It used to be that print.c would print extended-read-syntax
+ symbols with backslashes before "non-standard" chars, but
+ this routine wouldn't do anything with those escapes.
+ Bummer. What we've done is to change print.c to output
+ R6RS hex escapes for those characters, relying on the fact
+ that the extended read syntax would never put a `\' before
+ an `x'. For now, we just ignore other instances of
+ backslash in the string. */
+ switch ((chr = scm_getc (port)))
+ {
+ case EOF:
+ goto done;
+ case 'x':
+ {
+ scm_t_wchar c;
+
+ SCM_READ_HEX_ESCAPE (10, ';');
+ scm_i_string_set_x (buf, len++, c);
+ break;
+
+ str_eof:
+ chr = EOF;
+ goto done;
+
+ bad_escaped:
+ scm_i_string_stop_writing ();
+ scm_i_input_error ("scm_read_extended_symbol", port,
+ "illegal character in escape sequence: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ break;
+ }
+ default:
+ scm_i_string_set_x (buf, len++, chr);
+ break;
+ }
+ }
else
- scm_i_string_set_x (buf, len++, chr);
+ scm_i_string_set_x (buf, len++, chr);
if (len >= scm_i_string_length (buf) - 2)
{
SCM addy;
scm_i_string_stop_writing ();
- addy = scm_i_make_string (1024, NULL);
+ addy = scm_i_make_string (1024, NULL, 0);
buf = scm_string_append (scm_list_2 (buf, addy));
len = 0;
buf = scm_i_string_start_writing (buf);
}
-
- if (finished)
- break;
}
+
+ done:
scm_i_string_stop_writing ();
+ if (chr == EOF)
+ scm_i_input_error ("scm_read_extended_symbol", port,
+ "end of file while reading symbol", SCM_EOL);
return (scm_string_to_symbol (scm_c_substring (buf, 0, len)));
}
SCM got;
got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
- if (!scm_is_eq (got, SCM_UNSPECIFIED))
- {
- if (SCM_RECORD_POSITIONS_P)
- return (recsexpr (got, line, column,
- SCM_FILENAME (port)));
- else
- return got;
- }
+
+ if (scm_is_pair (got) && !scm_i_has_source_properties (got))
+ scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));
+
+ return got;
}
return SCM_UNSPECIFIED;
/* The reader for the sharp `#' character. It basically dispatches reads
among the above token readers. */
static SCM
-scm_read_sharp (scm_t_wchar chr, SCM port)
+scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column)
#define FUNC_NAME "scm_lreadr"
{
SCM result;
case '\\':
return (scm_read_character (chr, port));
case '(':
- return (scm_read_vector (chr, port));
+ 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));
+ return (scm_read_srfi4_vector (chr, port, line, column));
case 'v':
- return (scm_read_bytevector (chr, port));
+ return (scm_read_bytevector (chr, port, line, column));
case '*':
- return (scm_read_guile_bit_vector (chr, port));
+ return (scm_read_guile_bit_vector (chr, port, line, column));
case 't':
case 'T':
case 'F':
- /* This one may return either a boolean or an SRFI-4 vector. */
return (scm_read_boolean (chr, port));
case ':':
return (scm_read_keyword (chr, port));
#if SCM_ENABLE_DEPRECATED
/* See below for 'i' and 'e'. */
case 'a':
- case 'c':
case 'y':
case 'h':
case 'l':
#endif
- return (scm_i_read_array (port, chr));
+ return (scm_read_array (chr, port, line, column));
case 'i':
case 'e':
if (next_c != EOF)
scm_ungetc (next_c, port);
if (next_c == '(')
- return scm_i_read_array (port, chr);
+ return scm_read_array (chr, port, line, column);
/* Fall through. */
}
#endif
{
while (1)
{
- register scm_t_wchar chr;
+ scm_t_wchar chr;
chr = scm_getc (port);
return (scm_read_quote (chr, port));
case '#':
{
- SCM result;
- result = scm_read_sharp (chr, port);
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+ SCM result = scm_read_sharp (chr, port, line, column);
if (scm_is_eq (result, SCM_UNSPECIFIED))
/* We read a comment or some such. */
break;
\f
-/* Used when recording expressions constructed by `scm_read_sharp ()'. */
-static SCM
-recsexpr (SCM obj, long line, int column, SCM filename)
-{
- if (!scm_is_pair(obj)) {
- return obj;
- } else {
- SCM tmp = obj, copy;
- /* If this sexpr is visible in the read:sharp source, we want to
- keep that information, so only record non-constant cons cells
- which haven't previously been read by the reader. */
- if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
- {
- if (SCM_COPY_SOURCE_P)
- {
- copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
- SCM_UNDEFINED);
- while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
- {
- SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
- line,
- column,
- filename),
- SCM_UNDEFINED));
- copy = SCM_CDR (copy);
- }
- SCM_SETCDR (copy, tmp);
- }
- else
- {
- recsexpr (SCM_CAR (obj), line, column, filename);
- while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
- recsexpr (SCM_CAR (tmp), line, column, filename);
- copy = SCM_UNDEFINED;
- }
- scm_whash_insert (scm_source_whash,
- obj,
- scm_make_srcprops (line,
- column,
- filename,
- copy,
- SCM_EOL));
- }
- return obj;
- }
-}
-
/* 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,
char *
scm_i_scan_for_encoding (SCM port)
{
+ scm_t_port *pt;
char header[SCM_ENCODING_SEARCH_SIZE+1];
size_t bytes_read, encoding_length, i;
char *encoding = NULL;
char *pos, *encoding_start;
int in_comment;
- if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
- /* PORT is a non-seekable file port (e.g., as created by Bash when using
- "guile <(echo '(display "hello")')") so bail out. */
- return NULL;
+ pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
- bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
- header[bytes_read] = '\0';
+ if (pt->read_pos == pt->read_end)
+ {
+ /* We can use the read buffer, and thus avoid a seek. */
+ if (scm_fill_input (port) == EOF)
+ return NULL;
- scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
+ bytes_read = pt->read_end - pt->read_pos;
+ if (bytes_read > SCM_ENCODING_SEARCH_SIZE)
+ bytes_read = SCM_ENCODING_SEARCH_SIZE;
+
+ if (bytes_read <= 1)
+ /* An unbuffered port -- don't scan. */
+ return NULL;
+
+ memcpy (header, pt->read_pos, bytes_read);
+ header[bytes_read] = '\0';
+ }
+ else
+ {
+ /* Try to read some bytes and then seek back. Not all ports
+ support seeking back; and indeed some file ports (like
+ /dev/urandom) will succeed on an lseek (fd, 0, SEEK_CUR)---the
+ check performed by SCM_FPORT_FDES---but fail to seek
+ backwards. Hence this block comes second. We prefer to use
+ the read buffer in-place. */
+ 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);
+ header[bytes_read] = '\0';
+ 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')
pos = encoding_start;
while (pos >= header)
{
- if (*pos == '\n')
+ if (*pos == ';')
+ {
+ in_comment = 1;
+ break;
+ }
+ else if (*pos == '\n' || pos == header)
{
/* This wasn't in a semicolon comment. Check for a
hash-bang comment. */
char *beg = strstr (header, "#!");
char *end = strstr (header, "!#");
- if (beg < encoding_start && encoding_start + encoding_length < end)
+ if (beg < encoding_start && encoding_start + encoding_length <= end)
in_comment = 1;
break;
}
- if (*pos == ';')
- {
- in_comment = 1;
- break;
- }
- pos --;
+ else
+ {
+ pos --;
+ continue;
+ }
}
if (!in_comment)
/* This wasn't in a comment */
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"
+ "near the top of the contents of a port with random-accessible contents.\n"
"The coding declaration is of the form\n"
"@code{coding: XXXXX} and must appear in a scheme comment.\n"
"\n"
char *enc;
SCM s_enc;
+ SCM_VALIDATE_OPINPORT (SCM_ARG1, port);
+
enc = scm_i_scan_for_encoding (port);
if (enc == NULL)
return SCM_BOOL_F;
{
SCM read_hash_procs;
- read_hash_procs = scm_make_fluid ();
- scm_fluid_set_x (read_hash_procs, SCM_EOL);
+ read_hash_procs = scm_make_fluid_with_default (SCM_EOL);
scm_i_read_hash_procedures =
SCM_VARIABLE_LOC (scm_c_define ("%read-hash-procedures", read_hash_procs));
HCoop / bpt / guile.git / blobdiff