diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 2 | ||||
-rw-r--r-- | libguile/__scm.h | 2 | ||||
-rw-r--r-- | libguile/array-map.c | 3 | ||||
-rw-r--r-- | libguile/arrays.c | 26 | ||||
-rw-r--r-- | libguile/arrays.h | 11 | ||||
-rw-r--r-- | libguile/backtrace.c | 13 | ||||
-rw-r--r-- | libguile/bitvectors.c | 32 | ||||
-rw-r--r-- | libguile/bitvectors.h | 2 | ||||
-rw-r--r-- | libguile/eq.c | 19 | ||||
-rw-r--r-- | libguile/evalext.c | 2 | ||||
-rw-r--r-- | libguile/fports.c | 1 | ||||
-rw-r--r-- | libguile/goops.c | 10 | ||||
-rw-r--r-- | libguile/i18n.c | 22 | ||||
-rw-r--r-- | libguile/load.c | 12 | ||||
-rw-r--r-- | libguile/objcodes.c | 7 | ||||
-rw-r--r-- | libguile/print.c | 14 | ||||
-rw-r--r-- | libguile/srfi-13.c | 170 | ||||
-rw-r--r-- | libguile/srfi-60.c | 4 | ||||
-rw-r--r-- | libguile/strings.c | 16 | ||||
-rw-r--r-- | libguile/strings.h | 2 | ||||
-rw-r--r-- | libguile/tags.h | 6 | ||||
-rw-r--r-- | libguile/threads.c | 5 |
22 files changed, 220 insertions, 161 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 502ae56fa..52ffc34be 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -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 diff --git a/libguile/__scm.h b/libguile/__scm.h index ee73855c6..d0a421371 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -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 diff --git a/libguile/array-map.c b/libguile/array-map.c index 395fa11a0..acd167da6 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -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); } diff --git a/libguile/arrays.c b/libguile/arrays.c index bcc351cb1..935d6f363 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -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" diff --git a/libguile/arrays.h b/libguile/arrays.h index 9b14d4e36..5ea604d6a 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -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); diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 351e600a1..11a0cb1ee 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -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; diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 5b5a1b8e2..bc273a3b1 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -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" } diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h index b6cf38357..6b25327a8 100644 --- a/libguile/bitvectors.h +++ b/libguile/bitvectors.h @@ -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 */ diff --git a/libguile/eq.c b/libguile/eq.c index 5e270a25c..5a6f574d2 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -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); diff --git a/libguile/evalext.c b/libguile/evalext.c index 779c63d0a..3e04a7a59 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -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: diff --git a/libguile/fports.c b/libguile/fports.c index 683c25bde..97dadded5 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -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> diff --git a/libguile/goops.c b/libguile/goops.c index df1a64f7f..5e846eeae 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -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>", diff --git a/libguile/i18n.c b/libguile/i18n.c index c0deb98d4..f833e5d16 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -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))) { diff --git a/libguile/load.c b/libguile/load.c index b28e30b2a..135a621cb 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -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 diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 5db8ed3e2..df10ea3ce 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -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 { diff --git a/libguile/print.c b/libguile/print.c index d8dd24c06..a1c36eb94 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -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_wvect: + case scm_tc7_array: ENTER_NESTED_DATA (pstate, exp, circref); - scm_puts_unlocked ("#w(", port); - goto common_vector_printer; - + 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_vector: ENTER_NESTED_DATA (pstate, exp, circref); scm_puts_unlocked ("#(", port); diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 5bba81c7f..92d4a9d70 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -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)); + + 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); + scm_remember_upto_here_2 (target, s); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/srfi-60.c b/libguile/srfi-60.c index 264f4cbd5..1ed3c9e81 100644 --- a/libguile/srfi-60.c +++ b/libguile/srfi-60.c @@ -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)) { diff --git a/libguile/strings.c b/libguile/strings.c index b9963010f..cb883fa73 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -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" } diff --git a/libguile/strings.h b/libguile/strings.h index 0c163db5a..04a976211 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -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. */ diff --git a/libguile/tags.h b/libguile/tags.h index 54b74e0a2..fb550479d 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -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 diff --git a/libguile/threads.c b/libguile/threads.c index 80631b454..0dba50f8a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -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 |