mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 18:20:22 +02:00
Code Activity

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

Browse source 
Conflicts:
	libguile/__scm.h
	libguile/array-map.c
	libguile/procprop.c
	libguile/tags.h
	module/ice-9/deprecated.scm
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
	test-suite/standalone/test-num2integral.c
	test-suite/tests/regexp.test
This commit is contained in:
Andy Wingo 2012-01-10 00:41:42 +01:00
commit 91ee7515da
64 changed files with 1024 additions and 648 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/Makefile.am
View file

@ -62,7 +62,7 @@ gen-scmconfig.$(OBJEXT): gen-scmconfig.c
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
$(CC_FOR_BUILD) $(DEFS) $(DEFAULT_INCLUDES) -I$(top_builddir) \
-c -o $@ $<; \
-c -o $@ $<; \
else \
$(COMPILE) -c -o $@ $<; \
fi

2
libguile/__scm.h
View file

@ -4,7 +4,7 @@
#define SCM___SCM_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2006,
* 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
* 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

3
libguile/array-map.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 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
@ -892,7 +892,6 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
void
scm_init_array_map (void)
{
scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_array_equal_p;
#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
}

26
libguile/arrays.c
View file

@ -33,7 +33,6 @@
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/fports.h"
#include "libguile/smob.h"
#include "libguile/feature.h"
#include "libguile/root.h"
#include "libguile/strings.h"
@ -54,11 +53,10 @@
#include "libguile/uniform.h"
scm_t_bits scm_i_tc16_array;
#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
(SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
(SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
@ -111,14 +109,14 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
}
#undef FUNC_NAME
SCM
SCM
scm_i_make_array (int ndim)
{
SCM ra;
SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array,
scm_gc_malloc ((sizeof (scm_i_t_array) +
ndim * sizeof (scm_t_array_dim)),
"array"));
ra = scm_cell (((scm_t_bits) ndim << 17) + scm_tc7_array,
(scm_t_bits) scm_gc_malloc (sizeof (scm_i_t_array) +
ndim * sizeof (scm_t_array_dim),
"array"));
SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
return ra;
}
@ -743,7 +741,7 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
/* Print an array.
*/
static int
int
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
scm_t_array_handle h;
@ -1015,18 +1013,14 @@ array_get_handle (SCM array, scm_t_array_handle *h)
h->base = SCM_I_ARRAY_BASE (array);
}
SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array),
SCM_SMOB_TYPE_MASK,
SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
0x7f,
array_handle_ref, array_handle_set,
array_get_handle)
void
scm_init_arrays ()
{
scm_i_tc16_array = scm_make_smob_type ("array", 0);
scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
scm_add_feature ("array");
#include "libguile/arrays.x"

11
libguile/arrays.h
View file

@ -59,21 +59,20 @@ typedef struct scm_i_t_array
unsigned long base;
} scm_i_t_array;
SCM_INTERNAL scm_t_bits scm_i_tc16_array;
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_SMOB_FLAGS (x)>>1))
#define SCM_I_ARRAY_CONTP(x) (SCM_SMOB_FLAGS(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))
#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_SMOB_DATA_1 (a))
#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
#define SCM_I_ARRAY_DIMS(a) \
((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (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);

13
libguile/backtrace.c
View file

@ -144,6 +144,19 @@ SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
{
SCM_VALIDATE_OUTPUT_PORT (2, port);
#if SCM_ENABLE_DEPRECATED
if (SCM_STACKP (frame))
{
scm_c_issue_deprecation_warning
("Passing a stack as the first argument to `scm_display_error' is "
"deprecated. Pass a frame instead.");
if (SCM_STACK_LENGTH (frame))
frame = scm_stack_ref (frame, SCM_INUM0);
else
frame = SCM_BOOL_F;
}
#endif
scm_i_display_error (frame, port, subr, message, args, rest);
return SCM_UNSPECIFIED;

32
libguile/bitvectors.c
View file

@ -1,4 +1,4 @@
/* 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
@ -27,7 +27,6 @@
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/smob.h"
#include "libguile/strings.h"
#include "libguile/array-handle.h"
#include "libguile/bitvectors.h"
@ -39,14 +38,12 @@
* but alack, all we have is this crufty C.
*/
static scm_t_bits scm_tc16_bitvector;
#define IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj))
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_1(obj))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_2(obj))
#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
static int
bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
{
size_t bit_len = BITVECTOR_LENGTH (vec);
size_t word_len = (bit_len+31)/32;
@ -64,8 +61,8 @@ bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
return 1;
}
static SCM
bitvector_equalp (SCM vec1, SCM vec2)
SCM
scm_i_bitvector_equal_p (SCM vec1, SCM vec2)
{
size_t bit_len = BITVECTOR_LENGTH (vec1);
size_t word_len = (bit_len + 31) / 32;
@ -113,7 +110,7 @@ scm_c_make_bitvector (size_t len, SCM fill)
bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len,
"bitvector");
SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
res = scm_double_cell (scm_tc7_bitvector, (scm_t_bits)bits, len, 0);
if (!SCM_UNBNDP (fill))
scm_bitvector_fill_x (res, fill);
@ -145,7 +142,8 @@ SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
size_t
scm_c_bitvector_length (SCM vec)
{
scm_assert_smob_type (scm_tc16_bitvector, vec);
if (!IS_BITVECTOR (vec))
scm_wrong_type_arg_msg (NULL, 0, vec, "bitvector");
return BITVECTOR_LENGTH (vec);
}
@ -880,8 +878,8 @@ bitvector_get_handle (SCM bv, scm_t_array_handle *h)
h->elements = h->writable_elements = BITVECTOR_BITS (bv);
}
SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_bitvector),
SCM_SMOB_TYPE_MASK,
SCM_ARRAY_IMPLEMENTATION (scm_tc7_bitvector,
0x7f,
bitvector_handle_ref, bitvector_handle_set,
bitvector_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector)
@ -889,10 +887,6 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector)
void
scm_init_bitvectors ()
{
scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
#include "libguile/bitvectors.x"
}

2
libguile/bitvectors.h
View file

@ -70,6 +70,8 @@ SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
size_t *lenp,
ssize_t *incp);
SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2);
SCM_INTERNAL void scm_init_bitvectors (void);
#endif /* SCM_BITVECTORS_H */

19
libguile/eq.c
View file

@ -302,10 +302,6 @@ scm_equal_p (SCM x, SCM y)
y = SCM_CDR(y);
goto tailrecurse;
}
if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string)
return scm_string_equal_p (x, y);
if (SCM_TYP7 (x) == scm_tc7_bytevector && SCM_TYP7 (y) == scm_tc7_bytevector)
return scm_bytevector_eq_p (x, y);
if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
{
int i = SCM_SMOBNUM (x);
@ -316,8 +312,6 @@ scm_equal_p (SCM x, SCM y)
else
goto generic_equal;
}
if (SCM_POINTER_P (x) && SCM_POINTER_P (y))
return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y));
/* This ensures that types and scm_length are the same. */
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
@ -352,7 +346,20 @@ scm_equal_p (SCM x, SCM y)
return scm_complex_equalp (x, y);
case scm_tc16_fraction:
return scm_i_fraction_equalp (x, y);
default:
/* assert not reached? */
return SCM_BOOL_F;
}
case scm_tc7_pointer:
return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y));
case scm_tc7_string:
return scm_string_equal_p (x, y);
case scm_tc7_bytevector:
return scm_bytevector_eq_p (x, y);
case scm_tc7_array:
return scm_array_equal_p (x, y);
case scm_tc7_bitvector:
return scm_i_bitvector_equal_p (x, y);
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_i_vector_equal_p (x, y);

2
libguile/evalext.c
View file

@ -89,6 +89,8 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_smob:
case scm_tc7_program:
case scm_tc7_bytevector:
case scm_tc7_array:
case scm_tc7_bitvector:
case scm_tcs_struct:
return SCM_BOOL_T;
default:

1
libguile/fports.c
View file

@ -20,6 +20,7 @@
#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
#define _GNU_SOURCE /* ask for LONG_LONG_MAX/LONG_LONG_MIN */
#ifdef HAVE_CONFIG_H
# include <config.h>

10
libguile/goops.c
View file

@ -160,6 +160,8 @@ static SCM class_vm;
static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
static SCM class_array;
static SCM class_bitvector;
static SCM vtable_class_map = SCM_BOOL_F;
@ -275,6 +277,10 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_bytevector;
else
return class_uvec;
case scm_tc7_array:
return class_array;
case scm_tc7_bitvector:
return class_bitvector;
case scm_tc7_string:
return scm_class_string;
case scm_tc7_number:
@ -2519,6 +2525,10 @@ create_standard_classes (void)
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_uvec, "<uvec>",
scm_class_class, class_bytevector, SCM_EOL);
make_stdcls (&class_array, "<array>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_bitvector, "<bitvector>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_number, "<number>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_complex, "<complex>",

22
libguile/i18n.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 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
@ -196,22 +196,11 @@ typedef struct scm_locale
int category_mask;
} *scm_t_locale;
/* Free the resources used by LOCALE. */
static inline void
scm_i_locale_free (scm_t_locale locale)
{
free (locale->locale_name);
locale->locale_name = NULL;
}
#else /* USE_GNU_LOCALE_API */
/* Alias for glibc's locale type. */
typedef locale_t scm_t_locale;
#define scm_i_locale_free freelocale
#endif /* USE_GNU_LOCALE_API */
@ -244,16 +233,20 @@ SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");
SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0);
#ifdef USE_GNU_LOCALE_API
SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
{
scm_t_locale c_locale;
c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
scm_i_locale_free (c_locale);
freelocale (c_locale);
return 0;
}
#endif /* USE_GNU_LOCALE_API */
static void inline scm_locale_error (const char *, int) SCM_NORETURN;
@ -667,7 +660,8 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
c_locale->category_mask = c_category_mask;
c_locale->locale_name = c_locale_name;
c_locale->locale_name = scm_gc_strdup (c_locale_name, "locale");
free (c_locale_name);
if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
{

12
libguile/load.c
View file

@ -87,7 +87,9 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
#define FUNC_NAME s_scm_primitive_load
{
SCM hook = *scm_loc_load_hook;
SCM ret = SCM_UNSPECIFIED;
char *encoding;
SCM_VALIDATE_STRING (1, filename);
if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
@ -96,8 +98,10 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
if (!scm_is_false (hook))
scm_call_1 (hook, filename);
{ /* scope */
SCM port = scm_open_file (filename, scm_from_locale_string ("r"));
{
SCM port;
port = scm_open_file (filename, scm_from_locale_string ("r"));
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_i_dynwind_current_load_port (port);
@ -124,13 +128,13 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
if (SCM_EOF_OBJECT_P (form))
break;
scm_primitive_eval_x (form);
ret = scm_primitive_eval_x (form);
}
scm_dynwind_end ();
scm_close_port (port);
}
return SCM_UNSPECIFIED;
return ret;
}
#undef FUNC_NAME

7
libguile/objcodes.c
View file

@ -145,7 +145,7 @@ verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
- scm_tc7_objcode | type | flags
- the struct scm_objcode C object
- the parent of this objcode: either another objcode, a bytevector,
or, in the case of mmap types, file descriptors (as an inum)
or, in the case of mmap types, #f
- "native code" -- not currently used.
*/
@ -203,12 +203,11 @@ make_objcode_from_file (int fd)
scm_from_size_t (total_len)));
}
/* FIXME: we leak ourselves and the file descriptor. but then again so does
dlopen(). */
(void) close (fd);
return scm_permanent_object
(scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0),
(scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
SCM_UNPACK (scm_from_int (fd)), 0));
SCM_BOOL_F_BITS, 0));
}
#else
{

14
libguile/print.c
View file

@ -651,14 +651,20 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_with_fluids:
scm_i_with_fluids_print (exp, port, pstate);
break;
case scm_tc7_array:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_i_print_array (exp, port, pstate);
break;
case scm_tc7_bytevector:
scm_i_print_bytevector (exp, port, pstate);
break;
case scm_tc7_bitvector:
scm_i_print_bitvector (exp, port, pstate);
break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts_unlocked ("#w(", port);
goto common_vector_printer;
case scm_tc7_bytevector:
scm_i_print_bytevector (exp, port, pstate);
break;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts_unlocked ("#(", port);

170
libguile/srfi-13.c
View file

@ -546,17 +546,20 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
MY_VALIDATE_SUBSTRING_SPEC (3, s,
4, start, cstart,
5, end, cend);
len = cend - cstart;
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
target = scm_i_string_start_writing (target);
for (i = 0; i < cend - cstart; i++)
if (cstart < cend)
{
scm_i_string_set_x (target, ctstart + i,
scm_i_string_ref (s, cstart + i));
len = cend - cstart;
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
target = scm_i_string_start_writing (target);
for (i = 0; i < cend - cstart; i++)
{
scm_i_string_set_x (target, ctstart + i,
scm_i_string_ref (s, cstart + i));
}
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (target);
}
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (target);
return SCM_UNSPECIFIED;
}
@ -970,11 +973,13 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
4, end, cend);
SCM_VALIDATE_CHAR (2, chr);
str = scm_i_string_start_writing (str);
for (k = cstart; k < cend; k++)
scm_i_string_set_x (str, k, SCM_CHAR (chr));
scm_i_string_stop_writing ();
if (cstart < cend)
{
str = scm_i_string_start_writing (str);
for (k = cstart; k < cend; k++)
scm_i_string_set_x (str, k, SCM_CHAR (chr));
scm_i_string_stop_writing ();
}
return SCM_UNSPECIFIED;
}
@ -2089,11 +2094,14 @@ string_upcase_x (SCM v, size_t start, size_t end)
{
size_t k;
v = scm_i_string_start_writing (v);
for (k = start; k < end; ++k)
scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k)));
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (v);
if (start < end)
{
v = scm_i_string_start_writing (v);
for (k = start; k < end; ++k)
scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k)));
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (v);
}
return v;
}
@ -2152,11 +2160,14 @@ string_downcase_x (SCM v, size_t start, size_t end)
{
size_t k;
v = scm_i_string_start_writing (v);
for (k = start; k < end; ++k)
scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k)));
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (v);
if (start < end)
{
v = scm_i_string_start_writing (v);
for (k = start; k < end; ++k)
scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k)));
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (v);
}
return v;
}
@ -2219,27 +2230,30 @@ string_titlecase_x (SCM str, size_t start, size_t end)
size_t i;
int in_word = 0;
str = scm_i_string_start_writing (str);
for(i = start; i < end; i++)
if (start < end)
{
ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i));
if (scm_is_true (scm_char_alphabetic_p (ch)))
{
if (!in_word)
{
scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch)));
in_word = 1;
}
else
{
scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch)));
}
}
else
in_word = 0;
str = scm_i_string_start_writing (str);
for(i = start; i < end; i++)
{
ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i));
if (scm_is_true (scm_char_alphabetic_p (ch)))
{
if (!in_word)
{
scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch)));
in_word = 1;
}
else
{
scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch)));
}
}
else
in_word = 0;
}
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (str);
}
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (str);
return str;
}
@ -2309,22 +2323,25 @@ SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
static void
string_reverse_x (SCM str, size_t cstart, size_t cend)
{
SCM tmp;
str = scm_i_string_start_writing (str);
if (cend > 0)
if (cstart < cend)
{
cend--;
while (cstart < cend)
{
tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart));
scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend));
scm_i_string_set_x (str, cend, SCM_CHAR (tmp));
cstart++;
cend--;
}
str = scm_i_string_start_writing (str);
if (cend > 0)
{
SCM tmp;
cend--;
while (cstart < cend)
{
tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart));
scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend));
scm_i_string_set_x (str, cend, SCM_CHAR (tmp));
cstart++;
cend--;
}
}
scm_i_string_stop_writing ();
}
scm_i_string_stop_writing ();
}
@ -2866,26 +2883,29 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
csto = csfrom + (cend - cstart);
else
csto = scm_to_int (sto);
if (cstart == cend && csfrom != csto)
SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
SCM_ASSERT_RANGE (1, tstart,
ctstart + (csto - csfrom) <= scm_i_string_length (target));
p = 0;
target = scm_i_string_start_writing (target);
while (csfrom < csto)
if (csfrom < csto)
{
size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
if (csfrom < 0)
scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t));
else
scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t));
csfrom++;
p++;
}
scm_i_string_stop_writing ();
if (cstart == cend)
SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
SCM_ASSERT_RANGE (1, tstart,
ctstart + (csto - csfrom) <= scm_i_string_length (target));
scm_remember_upto_here_2 (target, s);
p = 0;
target = scm_i_string_start_writing (target);
while (csfrom < csto)
{
size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
if (csfrom < 0)
scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t));
else
scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t));
csfrom++;
p++;
}
scm_i_string_stop_writing ();
scm_remember_upto_here_2 (target, s);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

4
libguile/srfi-60.c
View file

@ -70,7 +70,7 @@ SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0,
SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0,
(SCM index, SCM n, SCM bit),
(SCM index, SCM n, SCM newbit),
"Return @var{n} with the bit at @var{index} set according to\n"
"@var{newbit}. @var{newbit} should be @code{#t} to set the bit\n"
"to 1, or @code{#f} to set it to 0. Bits other than at\n"
@ -86,7 +86,7 @@ SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0,
int bb;
ii = scm_to_ulong (index);
bb = scm_to_bool (bit);
bb = scm_to_bool (newbit);
if (SCM_I_INUMP (n))
{

16
libguile/strings.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,2000,2001, 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
@ -436,6 +436,9 @@ scm_i_string_length (SCM str)
int
scm_i_is_narrow_string (SCM str)
{
if (IS_SH_STRING (str))
str = SH_STRING_STRING (str);
return !STRINGBUF_WIDE (STRING_STRINGBUF (str));
}
@ -446,6 +449,9 @@ scm_i_is_narrow_string (SCM str)
int
scm_i_try_narrow_string (SCM str)
{
if (IS_SH_STRING (str))
str = SH_STRING_STRING (str);
SET_STRING_STRINGBUF (str, narrow_stringbuf (STRING_STRINGBUF (str)));
return scm_i_is_narrow_string (str);
@ -664,6 +670,12 @@ scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr)
void
scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
{
if (IS_SH_STRING (str))
{
p += STRING_START (str);
str = SH_STRING_STRING (str);
}
if (chr > 0xFF && scm_i_is_narrow_string (str))
SET_STRING_STRINGBUF (str, wide_stringbuf (STRING_STRINGBUF (str)));
@ -2243,7 +2255,7 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
void
scm_init_strings ()
{
scm_nullstr = scm_i_make_string (0, NULL, 1);
scm_nullstr = scm_i_make_string (0, NULL, 0);
#include "libguile/strings.x"
}

2
libguile/strings.h
View file

@ -85,7 +85,7 @@
- SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH
is the same as scm_i_string_length. SCM_STRING_CHARS will throw
an error for for strings that are not null-terminated. There is
an error for strings that are not null-terminated. There is
no wide version of this interface.
*/

6
libguile/tags.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -440,8 +440,8 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#define scm_tc7_program 79
#define scm_tc7_weak_set 85
#define scm_tc7_weak_table 87
#define scm_tc7_unused_20 93
#define scm_tc7_unused_11 95
#define scm_tc7_array 93
#define scm_tc7_bitvector 95
#define scm_tc7_unused_12 101
#define scm_tc7_unused_18 103
#define scm_tc7_unused_13 109

5
libguile/threads.c
View file

@ -1,4 +1,6 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
* 2005, 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
@ -25,6 +27,7 @@
#include "libguile/bdw-gc.h"
#include "libguile/_scm.h"
#include <stdlib.h>
#if HAVE_UNISTD_H
#include <unistd.h>
#endif