mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Moved scm_i_struct_hash from struct.c to hash.c and made it static.

The port's alist is now a field of 'scm_t_port'.

Conflicts:
	libguile/arrays.c
	libguile/hash.c
	libguile/ports.c
	libguile/print.h
	libguile/read.c
This commit is contained in:
Mark H Weaver 2012-10-30 23:46:31 -04:00
commit fa980bcc0f
53 changed files with 1677 additions and 531 deletions
Download patch file Download diff file Expand all files Collapse all files

175
libguile/arrays.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
* 2006, 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
@ -814,178 +815,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
/* Read an array. This function can also read vectors and uniform
vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
handled here.
C is the first character read after the '#'.
*/
static int
read_decimal_integer (SCM port, int c, ssize_t *resp)
{
ssize_t sign = 1;
ssize_t res = 0;
int got_it = 0;
if (c == '-')
{
sign = -1;
c = scm_getc_unlocked (port);
}
while ('0' <= c && c <= '9')
{
res = 10*res + c-'0';
got_it = 1;
c = scm_getc_unlocked (port);
}
if (got_it)
*resp = sign * res;
return c;
}
SCM
scm_i_read_array (SCM port, int c)
{
ssize_t rank;
scm_t_wchar tag_buf[8];
int tag_len;
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 == '(')
{
scm_ungetc_unlocked (c, port);
return scm_vector (scm_read (port));
}
/* Disambiguate between '#f' and uniform floating point vectors.
*/
if (c == 'f')
{
c = scm_getc_unlocked (port);
if (c != '3' && c != '6')
{
if (c != EOF)
scm_ungetc_unlocked (c, port);
return SCM_BOOL_F;
}
rank = 1;
tag_buf[0] = 'f';
tag_len = 1;
goto continue_reading_tag;
}
/* Read rank.
*/
rank = 1;
c = read_decimal_integer (port, c, &rank);
if (rank < 0)
scm_i_input_error (NULL, port, "array rank must be non-negative",
SCM_EOL);
/* Read tag.
*/
tag_len = 0;
continue_reading_tag:
while (c != EOF && c != '(' && c != '@' && c != ':'
&& tag_len < sizeof tag_buf / sizeof tag_buf[0])
{
tag_buf[tag_len++] = c;
c = scm_getc_unlocked (port);
}
if (tag_len == 0)
tag = SCM_BOOL_T;
else
{
tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
scm_list_1 (tag));
}
/* Read shape.
*/
if (c == '@' || c == ':')
{
shape = SCM_EOL;
do
{
ssize_t lbnd = 0, len = 0;
SCM s;
if (c == '@')
{
c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &lbnd);
}
s = scm_from_ssize_t (lbnd);
if (c == ':')
{
c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &len);
if (len < 0)
scm_i_input_error (NULL, port,
"array length must be non-negative",
SCM_EOL);
s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
}
shape = scm_cons (s, shape);
} while (c == '@' || c == ':');
shape = scm_reverse_x (shape, SCM_EOL);
}
/* Read nested lists of elements.
*/
if (c != '(')
scm_i_input_error (NULL, port,
"missing '(' in vector or array literal",
SCM_EOL);
scm_ungetc_unlocked (c, port);
elements = scm_read (port);
if (scm_is_false (shape))
shape = scm_from_ssize_t (rank);
else if (scm_ilength (shape) != rank)
scm_i_input_error
(NULL, port,
"the number of shape specifications must match the array rank",
SCM_EOL);
/* Handle special print syntax of rank zero arrays; see
scm_i_print_array for a rationale.
*/
if (rank == 0)
{
if (!scm_is_pair (elements))
scm_i_input_error (NULL, port,
"too few elements in array literal, need 1",
SCM_EOL);
if (!scm_is_null (SCM_CDR (elements)))
scm_i_input_error (NULL, port,
"too many elements in array literal, want 1",
SCM_EOL);
elements = SCM_CAR (elements);
}
/* Construct array.
*/
return scm_list_to_typed_array (tag, shape, elements);
}
static SCM
array_handle_ref (scm_t_array_handle *h, size_t pos)
{

4
libguile/arrays.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_ARRAY_H
#define SCM_ARRAY_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009,
* 2010, 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
@ -73,7 +74,6 @@ typedef struct scm_i_t_array
SCM_INTERNAL SCM scm_i_make_array (int ndim);
SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);
SCM_INTERNAL void scm_init_arrays (void);

52
libguile/hash.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 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
@ -223,6 +224,53 @@ scm_i_utf8_string_hash (const char *str, size_t len)
return ret;
}
static unsigned long scm_raw_ihashq (scm_t_bits key);
static unsigned long scm_raw_ihash (SCM obj, size_t depth);
/* Return the hash of struct OBJ. Traverse OBJ's fields to compute the
result, unless DEPTH is zero. Assumes that OBJ is a struct. */
static unsigned long
scm_i_struct_hash (SCM obj, size_t depth)
{
SCM layout;
scm_t_bits *data;
size_t struct_size, field_num;
unsigned long hash;
layout = SCM_STRUCT_LAYOUT (obj);
struct_size = scm_i_symbol_length (layout) / 2;
data = SCM_STRUCT_DATA (obj);
hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
if (depth > 0)
for (field_num = 0; field_num < struct_size; field_num++)
{
int protection;
protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
if (protection != 'h' && protection != 'o')
{
int type;
type = scm_i_symbol_ref (layout, field_num * 2);
switch (type)
{
case 'p':
hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
depth / 2);
break;
case 'u':
hash ^= scm_raw_ihashq (data[field_num]);
break;
default:
/* Ignore 's' fields. */;
}
}
}
/* FIXME: Tail elements should be taken into account. */
return hash;
}
/* Thomas Wang's integer hasher, from
http://www.cris.com/~Ttwang/tech/inthash.htm. */
@ -298,6 +346,8 @@ scm_raw_ihash (SCM obj, size_t depth)
^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
else
return scm_raw_ihashq (scm_tc3_cons);
case scm_tcs_struct:
return scm_i_struct_hash (obj, depth);
default:
return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
}

17
libguile/list.c
View file

@ -267,7 +267,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1,
SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
(SCM lists),
(SCM args),
"A destructive version of @code{append} (@pxref{Pairs and\n"
"Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n"
"of each list's final pair is changed to point to the head of\n"
@ -276,26 +276,29 @@ SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
#define FUNC_NAME s_scm_append_x
{
SCM ret, *loc;
SCM_VALIDATE_REST_ARGUMENT (lists);
int argnum = 1;
SCM_VALIDATE_REST_ARGUMENT (args);
if (scm_is_null (lists))
if (scm_is_null (args))
return SCM_EOL;
loc = &ret;
for (;;)
{
SCM arg = SCM_CAR (lists);
SCM arg = SCM_CAR (args);
*loc = arg;
lists = SCM_CDR (lists);
if (scm_is_null (lists))
args = SCM_CDR (args);
if (scm_is_null (args))
return ret;
if (!SCM_NULL_OR_NIL_P (arg))
{
SCM_VALIDATE_CONS (SCM_ARG1, arg);
SCM_VALIDATE_CONS (argnum, arg);
loc = SCM_CDRLOC (scm_last_pair (arg));
SCM_VALIDATE_NULL_OR_NIL (argnum, *loc);
}
argnum++;
}
}
#undef FUNC_NAME

4
libguile/ports.c
View file

@ -613,6 +613,8 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits,
entry->ilseq_handler = handler;
entry->iconv_descriptors = NULL;
entry->alist = SCM_EOL;
if (SCM_PORT_DESCRIPTOR (ret)->free)
scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
@ -2370,7 +2372,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
if (end == (size_t) -1)
end = scm_i_string_length (str);
scm_display (scm_c_substring (str, start, end), port);
scm_i_display_substring (str, start, end, port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_WRITE;

4
libguile/ports.h
View file

@ -132,6 +132,10 @@ typedef struct
scm_t_port_encoding_mode encoding_mode;
scm_t_string_failed_conversion_handler ilseq_handler;
scm_t_iconv_descriptors *iconv_descriptors;
/* an alist for storing additional information
(e.g. used to store per-port read options) */
SCM alist;
} scm_t_port;

23
libguile/print.c
View file

@ -1229,6 +1229,29 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
write_character_escaped (ch, string_escapes_p, port);
}
/* Display STR to PORT from START inclusive to END exclusive. */
void
scm_i_display_substring (SCM str, size_t start, size_t end, SCM port)
{
int narrow_p;
const char *buf;
size_t len, printed;
buf = scm_i_string_data (str);
len = end - start;
narrow_p = scm_i_is_narrow_string (str);
buf += start * (narrow_p ? sizeof (char) : sizeof (scm_t_wchar));
printed = display_string (buf, narrow_p, end - start, port,
PORT_CONVERSION_HANDLER (port));
if (SCM_UNLIKELY (printed < len))
scm_encoding_error (__func__, errno,
"cannot convert to output locale",
port, scm_c_string_ref (str, printed + start));
}
/* Print an integer.
*/

5
libguile/print.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_PRINT_H
#define SCM_PRINT_H
/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2004, 2006, 2008, 2010, 2012 Free Software Foundation, Inc.
/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006, 2008,
* 2010, 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
@ -78,6 +79,8 @@ SCM_API SCM scm_print_options (SCM setting);
SCM_API SCM scm_make_print_state (void);
SCM_API void scm_free_print_state (SCM print_state);
SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state);
SCM_INTERNAL void scm_i_display_substring (SCM str, size_t start, size_t end,
SCM port);
SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);

3
libguile/private-options.h
View file

@ -67,7 +67,8 @@ SCM_INTERNAL scm_t_option scm_read_opts[];
#define SCM_R6RS_ESCAPES_P scm_read_opts[4].val
#define SCM_SQUARE_BRACKETS_P scm_read_opts[5].val
#define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val
#define SCM_CURLY_INFIX_P scm_read_opts[7].val
#define SCM_N_READ_OPTIONS 6
#define SCM_N_READ_OPTIONS 7
#endif /* PRIVATE_OPTIONS */

835
libguile/read.c
View file

File diff suppressed because it is too large Load diff

1
libguile/read.h
View file

@ -54,7 +54,6 @@ SCM_API SCM scm_sym_dot;
SCM_API SCM scm_read_options (SCM setting);
SCM_API SCM scm_read (SCM port);
SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
SCM_INTERNAL char *scm_i_scan_for_encoding (SCM port);
SCM_API SCM scm_file_encoding (SCM port);

97
libguile/srfi-13.c
View file

@ -2993,11 +2993,22 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
(SCM str, SCM chr),
(SCM str, SCM char_pred),
"Split the string @var{str} into a list of the substrings delimited\n"
"by appearances of the character @var{chr}. Note that an empty substring\n"
"between separator characters will result in an empty string in the\n"
"result list.\n"
"by appearances of characters that\n"
"\n"
"@itemize @bullet\n"
"@item\n"
"equal @var{char_pred}, if it is a character,\n"
"\n"
"@item\n"
"satisfy the predicate @var{char_pred}, if it is a procedure,\n"
"\n"
"@item\n"
"are in the set @var{char_pred}, if it is a character set.\n"
"@end itemize\n\n"
"Note that an empty substring between separator characters\n"
"will result in an empty string in the result list.\n"
"\n"
"@lisp\n"
"(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
@ -3014,47 +3025,73 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_string_split
{
long idx, last_idx;
int narrow;
SCM res = SCM_EOL;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_CHAR (2, chr);
/* This is explicit wide/narrow logic (instead of using
scm_i_string_ref) is a speed optimization. */
idx = scm_i_string_length (str);
narrow = scm_i_is_narrow_string (str);
if (narrow)
if (SCM_CHARP (char_pred))
{
const char *buf = scm_i_string_chars (str);
while (idx >= 0)
long idx, last_idx;
int narrow;
/* This is explicit wide/narrow logic (instead of using
scm_i_string_ref) is a speed optimization. */
idx = scm_i_string_length (str);
narrow = scm_i_is_narrow_string (str);
if (narrow)
{
last_idx = idx;
while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
idx--;
if (idx >= 0)
const char *buf = scm_i_string_chars (str);
while (idx >= 0)
{
res = scm_cons (scm_i_substring (str, idx, last_idx), res);
idx--;
last_idx = idx;
while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(char_pred))
idx--;
if (idx >= 0)
{
res = scm_cons (scm_i_substring (str, idx, last_idx), res);
idx--;
}
}
}
else
{
const scm_t_wchar *buf = scm_i_string_wide_chars (str);
while (idx >= 0)
{
last_idx = idx;
while (idx > 0 && buf[idx-1] != SCM_CHAR(char_pred))
idx--;
if (idx >= 0)
{
res = scm_cons (scm_i_substring (str, idx, last_idx), res);
idx--;
}
}
}
}
else
{
const scm_t_wchar *buf = scm_i_string_wide_chars (str);
while (idx >= 0)
SCM sidx, slast_idx;
if (!SCM_CHARSETP (char_pred))
SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
char_pred, SCM_ARG2, FUNC_NAME);
/* Supporting predicates and character sets involves handling SCM
values so there is less chance to optimize. */
slast_idx = scm_string_length (str);
for (;;)
{
last_idx = idx;
while (idx > 0 && buf[idx-1] != SCM_CHAR(chr))
idx--;
if (idx >= 0)
{
res = scm_cons (scm_i_substring (str, idx, last_idx), res);
idx--;
}
sidx = scm_string_index_right (str, char_pred, SCM_INUM0, slast_idx);
if (scm_is_false (sidx))
break;
res = scm_cons (scm_substring (str, scm_oneplus (sidx), slast_idx), res);
slast_idx = sidx;
}
res = scm_cons (scm_substring (str, SCM_INUM0, slast_idx), res);
}
scm_remember_upto_here_1 (str);
return res;
}

2
libguile/srfi-13.h
View file

@ -110,7 +110,7 @@ SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end);
SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end);
SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end);
SCM_API SCM scm_string_split (SCM s, SCM chr);
SCM_API SCM scm_string_split (SCM s, SCM char_pred);
SCM_API SCM scm_string_filter (SCM char_pred, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_delete (SCM char_pred, SCM s, SCM start, SCM end);

4
libguile/strings.c
View file

@ -1997,7 +1997,10 @@ u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len)
char *
scm_to_utf8_stringn (SCM str, size_t *lenp)
#define FUNC_NAME "scm_to_utf8_stringn"
{
SCM_VALIDATE_STRING (1, str);
if (scm_i_is_narrow_string (str))
return (char *) latin1_to_u8 ((scm_t_uint8 *) scm_i_string_chars (str),
scm_i_string_length (str),
@ -2044,6 +2047,7 @@ scm_to_utf8_stringn (SCM str, size_t *lenp)
}
}
}
#undef FUNC_NAME
scm_t_wchar *
scm_to_utf32_string (SCM str)