/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004,
- * 2006, 2009, 2011 Free Software Foundation, Inc.
+ * 2006, 2009, 2011, 2013 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 <config.h>
#endif
+#include <unistr.h>
+
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/variable.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
-#include "libguile/threads.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
#include "libguile/modules.h"
#include "libguile/read.h"
#include "libguile/srfi-13.h"
\f
static SCM symbols;
-static scm_i_pthread_mutex_t symbols_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
lookup_interned_symbol (SCM name, unsigned long raw_hash)
{
struct string_lookup_data data;
- SCM handle;
data.string = name;
data.string_hash = raw_hash;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
- string_lookup_predicate_fn,
- &data);
- scm_i_pthread_mutex_unlock (&symbols_lock);
-
- if (scm_is_true (handle))
- return SCM_CAR (handle);
- else
- return SCM_BOOL_F;
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ string_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
struct latin1_lookup_data
unsigned long raw_hash)
{
struct latin1_lookup_data data;
- SCM handle;
data.str = str;
data.len = len;
data.string_hash = raw_hash;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
- latin1_lookup_predicate_fn,
- &data);
- scm_i_pthread_mutex_unlock (&symbols_lock);
-
- if (scm_is_true (handle))
- return SCM_CAR (handle);
- else
- return SCM_BOOL_F;
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ latin1_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
-static unsigned long
-symbol_lookup_hash_fn (SCM obj, unsigned long max, void *closure)
+struct utf8_lookup_data
{
- return scm_i_symbol_hash (obj) % max;
-}
+ const char *str;
+ size_t len;
+ unsigned long string_hash;
+};
-static SCM
-symbol_lookup_assoc_fn (SCM obj, SCM alist, void *closure)
+static int
+utf8_string_equals_wide_string (const scm_t_uint8 *narrow, size_t nlen,
+ const scm_t_wchar *wide, size_t wlen)
{
- for (; !scm_is_null (alist); alist = SCM_CDR (alist))
+ size_t byte_idx = 0, char_idx = 0;
+
+ while (byte_idx < nlen && char_idx < wlen)
{
- SCM sym = SCM_CAAR (alist);
+ ucs4_t c;
+ int nbytes;
- if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (obj)
- && scm_is_true (scm_string_equal_p (scm_symbol_to_string (sym),
- scm_symbol_to_string (obj))))
- return SCM_CAR (alist);
+ nbytes = u8_mbtouc (&c, narrow + byte_idx, nlen - byte_idx);
+ if (nbytes == 0)
+ break;
+ else if (c == 0xfffd)
+ /* Bad UTF-8. */
+ return 0;
+ else if (c != wide[char_idx])
+ return 0;
+
+ byte_idx += nbytes;
+ char_idx++;
}
- return SCM_BOOL_F;
+ return byte_idx == nlen && char_idx == wlen;
}
-/* Intern SYMBOL, an uninterned symbol. Might return a different
- symbol, if another one was interned at the same time. */
-static SCM
-intern_symbol (SCM symbol)
+static int
+utf8_lookup_predicate_fn (SCM sym, void *closure)
{
- SCM handle;
+ struct utf8_lookup_data *data = closure;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_create_handle_x (symbols, symbol, SCM_UNDEFINED,
- symbol_lookup_hash_fn,
- symbol_lookup_assoc_fn,
- NULL);
- scm_i_pthread_mutex_unlock (&symbols_lock);
+ if (scm_i_symbol_hash (sym) != data->string_hash)
+ return 0;
+
+ if (scm_i_is_narrow_symbol (sym))
+ return (scm_i_symbol_length (sym) == data->len
+ && strncmp (scm_i_symbol_chars (sym), data->str, data->len) == 0);
+ else
+ return utf8_string_equals_wide_string ((const scm_t_uint8 *) data->str,
+ data->len,
+ scm_i_symbol_wide_chars (sym),
+ scm_i_symbol_length (sym));
+}
+
+static SCM
+lookup_interned_utf8_symbol (const char *str, size_t len,
+ unsigned long raw_hash)
+{
+ struct utf8_lookup_data data;
- return SCM_CAR (handle);
+ data.str = str;
+ data.len = len;
+ data.string_hash = raw_hash;
+
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ utf8_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
+static int
+symbol_lookup_predicate_fn (SCM sym, void *closure)
+{
+ SCM other = SCM_PACK_POINTER (closure);
+
+ if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (other)
+ && scm_i_symbol_length (sym) == scm_i_symbol_length (other))
+ {
+ if (scm_i_is_narrow_symbol (sym))
+ return scm_i_is_narrow_symbol (other)
+ && (strncmp (scm_i_symbol_chars (sym),
+ scm_i_symbol_chars (other),
+ scm_i_symbol_length (other)) == 0);
+ else
+ return scm_is_true
+ (scm_string_equal_p (scm_symbol_to_string (sym),
+ scm_symbol_to_string (other)));
+ }
+ return 0;
+}
+
static SCM
scm_i_str2symbol (SCM str)
{
/* The symbol was not found, create it. */
symbol = scm_i_make_symbol (str, 0, raw_hash,
scm_cons (SCM_BOOL_F, SCM_EOL));
- return intern_symbol (symbol);
+
+ /* Might return a different symbol, if another one was interned at
+ the same time. */
+ return scm_c_weak_set_add_x (symbols, raw_hash,
+ symbol_lookup_predicate_fn,
+ SCM_UNPACK_POINTER (symbol), symbol);
}
}
/* The default prefix for `gensym'd symbols. */
static SCM default_gensym_prefix;
-#define GENSYM_LENGTH 22 /* bytes */
-#define GENSYM_RADIX_BITS 6
-#define GENSYM_RADIX (1 << (GENSYM_RADIX_BITS))
+#define MAX_PREFIX_LENGTH 30
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
(SCM prefix),
"resetting the counter.")
#define FUNC_NAME s_scm_gensym
{
- static const char base64[GENSYM_RADIX] =
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
- static const char base4[4] = "_.-~";
-
- unsigned char *digit_buf = SCM_I_CURRENT_THREAD->gensym_counter;
- char char_buf[GENSYM_LENGTH];
+ static int gensym_counter = 0;
+
SCM suffix, name;
- int i;
+ int n, n_digits;
+ char buf[SCM_INTBUFLEN];
if (SCM_UNBNDP (prefix))
prefix = default_gensym_prefix;
- if (SCM_UNLIKELY (digit_buf == NULL))
- {
- /* This is the first time gensym has been called in this thread.
- Allocate and randomize our new thread-local gensym counter */
- digit_buf = (unsigned char *)
- scm_gc_malloc_pointerless (GENSYM_LENGTH, "gensym-counter");
- scm_i_random_bytes_from_platform (digit_buf, GENSYM_LENGTH);
- for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
- digit_buf[i] &= (GENSYM_RADIX - 1);
- SCM_I_CURRENT_THREAD->gensym_counter = digit_buf;
- }
-
- /* Increment our thread-local gensym_counter. */
- for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
- {
- if (SCM_LIKELY (++(digit_buf[i]) < GENSYM_RADIX))
- break;
- else
- digit_buf[i] = 0;
- }
-
- /* Encode digit_buf as base64, except for the first character where we
- use the sparse glyphs "_.-~" (base 4) to provide some visual
- separation between the prefix and the dense base64 block. */
- for (i = (GENSYM_LENGTH - 1); i > 0; --i)
- char_buf[i] = base64[digit_buf[i]];
- char_buf[0] = base4[digit_buf[0] & 3];
+ /* mutex in case another thread looks and incs at the exact same moment */
+ scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
+ n = gensym_counter++;
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
- suffix = scm_from_latin1_stringn (char_buf, GENSYM_LENGTH);
+ n_digits = scm_iint2str (n, 10, buf);
+ suffix = scm_from_latin1_stringn (buf, n_digits);
name = scm_string_append (scm_list_2 (prefix, suffix));
return scm_string_to_symbol (name);
}
SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0,
(SCM s),
- "Return the contents of @var{symbol}'s @dfn{function slot}.")
+ "Return the contents of the symbol @var{s}'s @dfn{function slot}.")
#define FUNC_NAME s_scm_symbol_fref
{
SCM_VALIDATE_SYMBOL (1, s);
SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0,
(SCM s),
- "Return the @dfn{property list} currently associated with @var{symbol}.")
+ "Return the @dfn{property list} currently associated with the\n"
+ "symbol @var{s}.")
#define FUNC_NAME s_scm_symbol_pref
{
SCM_VALIDATE_SYMBOL (1, s);
SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
(SCM s, SCM val),
- "Change the binding of @var{symbol}'s function slot.")
+ "Change the binding of the symbol @var{s}'s function slot.")
#define FUNC_NAME s_scm_symbol_fset_x
{
SCM_VALIDATE_SYMBOL (1, s);
SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
(SCM s, SCM val),
- "Change the binding of @var{symbol}'s property slot.")
+ "Change the binding of the symbol @var{s}'s property slot.")
#define FUNC_NAME s_scm_symbol_pset_x
{
SCM_VALIDATE_SYMBOL (1, s);
SCM
scm_from_utf8_symboln (const char *sym, size_t len)
{
- SCM str = scm_from_utf8_stringn (sym, len);
- return scm_i_str2symbol (str);
+ unsigned long hash;
+ SCM ret;
+
+ if (len == (size_t) -1)
+ len = strlen (sym);
+ hash = scm_i_utf8_string_hash (sym, len);
+
+ ret = lookup_interned_utf8_symbol (sym, len, hash);
+ if (scm_is_false (ret))
+ {
+ SCM str = scm_from_utf8_stringn (sym, len);
+ ret = scm_i_str2symbol (str);
+ }
+
+ return ret;
}
void
scm_symbols_prehistory ()
{
- symbols = scm_make_weak_key_hash_table (scm_from_int (2139));
+ symbols = scm_c_make_weak_set (5000);
}
HCoop / bpt / guile.git / blobdiff