-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 1999, 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
* as published by the Free Software Foundation; either version 3 of
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<hash-table ", port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
}
#undef FUNC_NAME
+
\f
/* Accessing hash table entries. */
#define FUNC_NAME s_scm_hash_clear_x
{
if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_clear_x (table);
+ {
+ scm_weak_table_clear_x (table);
+ return SCM_UNSPECIFIED;
+ }
SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_ref
{
SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
(SCM table, SCM key, SCM val),
"Find the entry in @var{table} associated with @var{key}, and\n"
- "store @var{value} there. Uses @code{eq?} for equality testing.")
+ "store @var{val} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_putq_x (table, key, val);
+ {
+ scm_weak_table_putq_x (table, key, val);
+ return val;
+ }
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashq,
#define FUNC_NAME s_scm_hashq_remove_x
{
if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_remq_x (table, key);
+ {
+ scm_weak_table_remq_x (table, key);
+ /* This return value is for historical compatibility with
+ hash-remove!, which returns either the "handle" corresponding
+ to the entry, or #f. Since weak tables don't have handles, we
+ have to return #f. */
+ return SCM_BOOL_F;
+ }
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashq,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_ref
{
scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
assv_predicate, SCM_PACK (key),
key, val);
- return SCM_UNSPECIFIED;
+ return val;
}
return scm_hash_fn_set_x (table, key, val,
{
scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
assv_predicate, SCM_PACK (key));
- return SCM_UNSPECIFIED;
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
}
return scm_hash_fn_remove_x (table, key,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_ref
{
SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
(SCM table, SCM key, SCM val),
"Find the entry in @var{table} associated with @var{key}, and\n"
- "store @var{value} there. Uses @code{equal?} for equality\n"
+ "store @var{val} there. Uses @code{equal?} for equality\n"
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
scm_c_weak_table_put_x (table, scm_ihash (key, -1),
assoc_predicate, SCM_PACK (key),
key, val);
- return SCM_UNSPECIFIED;
+ return val;
}
return scm_hash_fn_set_x (table, key, val,
{
scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
assoc_predicate, SCM_PACK (key));
- return SCM_UNSPECIFIED;
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
}
return scm_hash_fn_remove_x (table, key,
unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
scm_from_ulong (-1)));
scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
- return SCM_UNSPECIFIED;
+ return val;
}
return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
scm_from_ulong (-1)));
scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
- return SCM_UNSPECIFIED;
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
}
return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
SCM_VALIDATE_PROC (1, proc);
if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_for_each (proc, table);
+ {
+ scm_weak_table_for_each (proc, table);
+ return SCM_UNSPECIFIED;
+ }
SCM_VALIDATE_HASHTABLE (2, table);
}
#undef FUNC_NAME
+static SCM
+count_proc (void *pred, SCM key, SCM data, SCM value)
+{
+ if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
+ return value;
+ else
+ return scm_oneplus(value);
+}
+
+SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
+ (SCM pred, SCM table),
+ "Return the number of elements in the given hash TABLE that\n"
+ "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
+ "the total number of elements, use `(const #t)' for PRED.")
+#define FUNC_NAME s_scm_hash_count
+{
+ SCM init;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_HASHTABLE (2, table);
+
+ init = scm_from_int (0);
+ return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
+ (void *) SCM_UNPACK (pred), init, table);
+}
+#undef FUNC_NAME
+
\f
SCM
HCoop / bpt / guile.git / blobdiff