commit 9d9a849c43826ed22b529229eaf960ab866e79a8
parent ce0f5b63ec8157281107b48191decbfedbd02bf1
Author: Oto Havle <havleoto@gmail.com>
Date: Sun, 22 Apr 2012 16:18:40 +0200
eq-hashtables: Lisp interface to internal hash tables.
Diffstat:
9 files changed, 688 insertions(+), 2 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -56,7 +56,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kgenvironments.o kgenv_mut.o kgcombiners.o kgcontinuations.o \
kgencapsulations.o kgpromises.o kgkd_vars.o kgks_vars.o kgports.o \
kgchars.o kgnumbers.o kgstrings.o kgbytevectors.o kgvectors.o \
- kgsystem.o kgerrors.o kgkeywords.o \
+ kgtables.o kgsystem.o kgerrors.o kgkeywords.o \
$(if $(USE_LIBFFI),kgffi.o)
# TEMP: in klisp there is no distinction between core & lib
@@ -258,7 +258,7 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgcontrol.h kgpairs_lists.h kgpair_mut.h kgenvironments.h kgenv_mut.h \
kgcombiners.h kgcontinuations.h kgencapsulations.h kgpromises.h \
kgkd_vars.h kgks_vars.h kgnumbers.h kgstrings.h kgchars.h kgports.h \
- kgbytevectors.h kgvectors.h kgsystem.h kgerrors.h kglibraries.h \
+ kgbytevectors.h kgvectors.h kgtables.h kgsystem.h kgerrors.h kglibraries.h \
kgffi.h keval.h krepl.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
@@ -276,6 +276,10 @@ kgsystem.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kerror.h ksystem.h kghelpers.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
kstring.h ktable.h kgsystem.h kinteger.h kmem.h imath.h kgc.h
+kgtables.o: kgtables.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
+ kpair.h kgc.h kvector.h kbytevector.h kghelpers.h kenvironment.h \
+ ksymbol.h kstring.h ktable.h kgtables.h
kgvectors.o: kgvectors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h kvector.h kbytevector.h kghelpers.h kenvironment.h \
diff --git a/src/kground.c b/src/kground.c
@@ -37,6 +37,7 @@
#include "kgports.h"
#include "kgbytevectors.h"
#include "kgvectors.h"
+#include "kgtables.h"
#include "kgsystem.h"
#include "kgerrors.h"
#include "kgkeywords.h"
@@ -117,6 +118,7 @@ void kinit_ground_env(klisp_State *K)
kinit_ports_ground_env(K);
kinit_bytevectors_ground_env(K);
kinit_vectors_ground_env(K);
+ kinit_tables_ground_env(K);
kinit_system_ground_env(K);
kinit_error_ground_env(K);
kinit_keywords_ground_env(K);
diff --git a/src/kgtables.c b/src/kgtables.c
@@ -0,0 +1,337 @@
+/*
+** kgtables.c
+** Hash table interface for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kapplicative.h"
+#include "koperative.h"
+#include "kcontinuation.h"
+#include "kerror.h"
+#include "kpair.h"
+
+#include "kghelpers.h"
+#include "kgtables.h"
+
+/* Provide lisp interface to internal hash tables. The interface
+ * is modeled after SRFI-69.
+ *
+ * MISSING FUNCTIONALITY
+ * - no user definable equivalence predicates
+ * - no user definable hash functions
+ * - hash function itself is not available
+ * - hash-table-ref/default not implemented
+ * - hash-table-update! not implemented
+ * - hash-table-for-each (hash-table-walk in SRFI-69) not implemented
+ *
+ * DEVIATIONS FROM SRFI-69
+ * - hash-table-size renamed to hash-table-length to match klisp's vector-length
+ * - hash-table-exists? and hash-table-delete! accept more than one key
+ * - hash-table-merge! accepts more than two arguments
+ *
+ * KNOWN BUGS
+ * - removing elements do not cause hash tables shrink
+ * - hash_table_merge() may compute too low initial table size
+ * - "array" optimization never used
+ *
+ * Hash tables are equal? if and only if they are eq?. Hash
+ * tables do not have external representation.
+ *
+ * BASIC OPERATIONS
+ *
+ * (hash-table? OBJECT...)
+ * Type predicate. Evaluates to #t iff all arguments are hash
+ * tables, and #f otherwise.
+ *
+ * (make-hash-table)
+ * Create new, empty hash table. Currently accepts no optional
+ * parameters (SRFI-69 allows user-defined hash function, etc.)
+ *
+ * (hash-table-set! TABLE KEY VALUE)
+ * Set KEY => VALUE in TABLE, silently replacing
+ * any existing binding. The result is #inert.
+ *
+ * (hash-table-ref TABLE KEY [THUNK])
+ * Returns value corresponding to KEY in TABLE, if present.
+ * If KEY is not bound and THUNK is given, returns result of
+ * evaluation of (THUNK) in the dynamic environment. Otherwise,
+ * an error is signalled.
+ *
+ * (hash-table-exists? TABLE KEY1 KEY2 ...)
+ * Returns #t if all keys KEY1, KEY2, ... are bound in TABLE.
+ * Returns #f otherwise.
+ *
+ * (hash-table-delete! TABLE KEY1 KEY2 ...)
+ * Removes binding of KEY1, KEY2, ... from TABLE. If keys are not
+ * present, nothing happens. The result is #inert.
+ *
+ * (hash-table-length TABLE)
+ * Returns number of KEY => VALUE bindings in TABLE.
+ *
+ * (hash-table-copy TABLE)
+ * Returns a copy of TABLE.
+ *
+ * (hash-table-merge T1 T2 ... Tn)
+ * Creates new hash table with all bindings from T1, T2, ... Tn.
+ * If more than one of the tables bind the same key, only the
+ * value from the table which is comes last in the argument
+ * list is preserved.
+ *
+ * (hash-table-merge! DEST T1 T2 ... Tn)
+ * Copy all bindings from T1, T2, ... Tn to DEST. If more than
+ * one of the tables bind the same key, only the value from the
+ * table which is comes last in the argument list is preserved.
+ * The result is #inert.
+ *
+ * HIGH-LEVEL CONSTRUCTORS
+ *
+ * (hash-table K1 V1 K2 V2 ...)
+ * Creates new hash table, binding Kn => Vn. If Ki = Kj for i < j,
+ * then Vj overrides Vi.
+ *
+ * (alist->hash-table ALIST)
+ * Creates new hash table from association list.
+ *
+ * WHOLE CONTENTS MANIPULATION
+ *
+ * (hash-table->alist TABLE)
+ * Returns list (KEY . VALUE) pairs from TABLE.
+ *
+ * (hash-table-keys TABLE)
+ * Returns list of all keys from TABLE.
+ *
+ * (hash-table-values TABLE)
+ * Returns list of all values from TABLE.
+ *
+ */
+
+static void make_hash_table(klisp_State *K)
+{
+ check_0p(K, K->next_value);
+ TValue tab = klispH_new(K,
+ 0, /* narray - not used in klisp */
+ 32, /* nhash - size of the hash table */
+ 0 /* wflags - no weak pointers */ );
+ kapply_cc(K, tab);
+}
+
+static void hash_table_setB(klisp_State *K)
+{
+ bind_3tp(K, K->next_value,
+ "hash table", ttistable, tab,
+ "any", anytype, key,
+ "any", anytype, val);
+ *klispH_set(K, tv2table(tab), key) = val;
+ kapply_cc(K, KINERT);
+}
+
+static void hash_table_ref(klisp_State *K)
+{
+ bind_al2tp(K, K->next_value,
+ "hash table", ttistable, tab,
+ "any", anytype, key,
+ dfl);
+ (void) get_opt_tpar(K, dfl, "combiner", ttiscombiner);
+
+ const TValue *node = klispH_get(tv2table(tab), key);
+ if (!ttisfree(*node)) {
+ kapply_cc(K, *node);
+ } else if (ttiscombiner(dfl)) {
+ while(ttisapplicative(dfl))
+ dfl = tv2app(dfl)->underlying;
+ ktail_call(K, dfl, KNIL, K->next_env);
+ } else {
+ klispE_throw_simple_with_irritants(K, "key not found",
+ 1, key);
+ }
+}
+
+static void hash_table_existsP(klisp_State *K)
+{
+ int32_t i, pairs;
+ TValue res = KTRUE;
+ bind_al1tp(K, K->next_value,
+ "hash table", ttistable, tab,
+ keys);
+ check_list(K, 1, keys, &pairs, NULL);
+
+ for (i = 0; i < pairs; i++, keys = kcdr(keys)) {
+ const TValue *node = klispH_get(tv2table(tab), kcar(keys));
+ if (ttisfree(*node)) {
+ res = KFALSE;
+ break;
+ }
+ }
+ kapply_cc(K, res);
+}
+
+static void hash_table_deleteB(klisp_State *K)
+{
+ int32_t i, pairs;
+ bind_al1tp(K, K->next_value,
+ "hash table", ttistable, tab,
+ keys);
+ check_list(K, 1, keys, &pairs, NULL);
+
+ for (i = 0; i < pairs; i++, keys = kcdr(keys)) {
+ TValue *node = klispH_set(K, tv2table(tab), kcar(keys));
+ if (!ttisfree(*node)) {
+ *node = KFREE; /* TODO: shrink ? */
+ }
+ }
+ kapply_cc(K, KINERT);
+}
+
+static void hash_table_length(klisp_State *K)
+{
+ bind_1tp(K, K->next_value, "hash table", ttistable, tab);
+ kapply_cc(K, i2tv(klispH_numuse(tv2table(tab))));
+}
+
+static void hash_table_constructor(klisp_State *K)
+{
+ int32_t pairs, cpairs, i;
+ TValue rest = K->next_value;
+ check_list(K, 1, rest, &pairs, &cpairs);
+ if ((pairs % 2 != 0) || (cpairs % 2 != 0))
+ klispE_throw_simple(K, "expected even number of arguments");
+
+ TValue tab = klispH_new(K, 0, 32 + 2 * pairs, 0);
+ krooted_tvs_push(K, tab);
+ for (i = 0; i < pairs; i += 2, rest = kcddr(rest))
+ *klispH_set(K, tv2table(tab), kcar(rest)) = kcadr(rest);
+ krooted_tvs_pop(K);
+ kapply_cc(K, tab);
+}
+
+static void alist_to_hash_table(klisp_State *K)
+{
+ int32_t pairs, i;
+ bind_1p(K, K->next_value, rest);
+ check_typed_list(K, kpairp, true, rest, &pairs, NULL);
+
+ TValue tab = klispH_new(K, 0, 32 + 2 * pairs, 0);
+ krooted_tvs_push(K, tab);
+ for (i = 0; i < pairs; i++, rest = kcdr(rest))
+ *klispH_set(K, tv2table(tab), kcaar(rest)) = kcdar(rest);
+ krooted_tvs_pop(K);
+ kapply_cc(K, tab);
+}
+
+static void hash_table_merge(klisp_State *K)
+{
+ int32_t pairs;
+ bool destructive = bvalue(K->next_xparams[0]);
+ bool only_one_arg = ivalue(K->next_xparams[1]);
+ TValue dest, rest = K->next_value;
+
+ check_typed_list(K, ktablep, true, rest, &pairs, NULL);
+ if (only_one_arg && pairs != 1) {
+ klispE_throw_simple(K, "expected one argument");
+ }
+ if (destructive) {
+ if (pairs == 0)
+ klispE_throw_simple(K, "expected at least one argument");
+ dest = kcar(rest);
+ rest = kcdr(rest);
+ pairs--;
+ } else {
+ dest = klispH_new(K, 0, 32 + 2 * pairs, 0);
+ }
+
+ krooted_tvs_push(K, dest);
+ while (pairs--) {
+ TValue key = KFREE, data;
+ Table *t = tv2table(kcar(rest));
+ while (klispH_next(K, t, &key, &data))
+ *klispH_set(K, tv2table(dest), key) = data;
+ rest = kcdr(rest);
+ }
+ krooted_tvs_pop(K);
+
+ kapply_cc(K, (destructive ? KINERT : dest));
+}
+
+/* table_elements(K, TAB, MKELT) calls MKELT(key, value)
+ * on each key=>value binding in TAB and returns a list
+ * of objects returned by MKELT. TAB must be rooted.
+ */
+static TValue table_elements
+ (klisp_State *K, Table *t,
+ TValue (*mkelt)(klisp_State *K, TValue k, TValue v))
+{
+ TValue key = KFREE, data, res = KNIL, elt = KINERT;
+
+ krooted_vars_push(K, &res);
+ krooted_vars_push(K, &elt);
+ while (klispH_next(K, t, &key, &data)) {
+ elt = mkelt(K, key, data);
+ res = kcons(K, elt, res);
+ }
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
+}
+
+static TValue mkelt_proj1(klisp_State *K, TValue k, TValue v)
+{
+ UNUSED(K);
+ UNUSED(v);
+ return k;
+}
+
+static TValue mkelt_proj2(klisp_State *K, TValue k, TValue v)
+{
+ UNUSED(K);
+ UNUSED(k);
+ return v;
+}
+
+static TValue mkelt_cons(klisp_State *K, TValue k, TValue v)
+{
+ return kcons(K, k, v);
+}
+
+static void hash_table_to_list(klisp_State *K)
+{
+ bind_1tp(K, K->next_value, "hash table", ttistable, tab);
+ TValue res = table_elements(K, tv2table(tab), pvalue(K->next_xparams[0]));
+ kapply_cc(K, res);
+}
+
+/* init ground */
+void kinit_tables_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ add_applicative(K, ground_env, "hash-table?", typep, 2, symbol,
+ i2tv(K_TTABLE));
+ add_applicative(K, ground_env, "make-hash-table", make_hash_table, 0);
+
+ add_applicative(K, ground_env, "hash-table-set!", hash_table_setB, 0);
+ add_applicative(K, ground_env, "hash-table-ref", hash_table_ref, 0);
+ add_applicative(K, ground_env, "hash-table-exists?", hash_table_existsP, 0);
+ add_applicative(K, ground_env, "hash-table-delete!", hash_table_deleteB, 0);
+ add_applicative(K, ground_env, "hash-table-length", hash_table_length, 0);
+
+ add_applicative(K, ground_env, "hash-table", hash_table_constructor, 0);
+ add_applicative(K, ground_env, "alist->hash-table", alist_to_hash_table, 0);
+
+ add_applicative(K, ground_env, "hash-table-merge", hash_table_merge, 2, KFALSE, KFALSE);
+ add_applicative(K, ground_env, "hash-table-copy", hash_table_merge, 2, KFALSE, KTRUE);
+ add_applicative(K, ground_env, "hash-table-merge!", hash_table_merge, 2, KTRUE, KFALSE);
+
+ add_applicative(K, ground_env, "hash-table-keys", hash_table_to_list, 1, p2tv(mkelt_proj1));
+ add_applicative(K, ground_env, "hash-table-values", hash_table_to_list, 1, p2tv(mkelt_proj2));
+ add_applicative(K, ground_env, "hash-table->alist", hash_table_to_list, 1, p2tv(mkelt_cons));
+}
diff --git a/src/kgtables.h b/src/kgtables.h
@@ -0,0 +1,15 @@
+/*
+** kgtables.h
+** Hash table interface for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgtables_h
+#define kgtables_h
+
+#include "kstate.h"
+
+/* init ground */
+void kinit_tables_ground_env(klisp_State *K);
+
+#endif
diff --git a/src/ktable.c b/src/ktable.c
@@ -641,3 +641,24 @@ int32_t klispH_getn (Table *t) {
return j; /* that is easy... */
else return unbound_search(t, j);
}
+
+/* Return number of used elements in the hashtable. Code copied
+ * from rehash(). */
+
+int32_t klispH_numuse(Table *t)
+{
+ int32_t nasize;
+ int32_t nums[MAXBITS+1]; /* nums[i] = number of keys between 2^(i-1) and 2^i */
+ int32_t i;
+ int32_t totaluse;
+ for (i=0; i<=MAXBITS; i++) nums[i] = 0; /* reset counts */
+ nasize = numusearray(t, nums); /* count keys in array part */
+ totaluse = nasize; /* all those keys are integer keys */
+ totaluse += numusehash(t, nums, &nasize); /* count keys in hash part */
+ return totaluse;
+}
+
+bool ktablep(TValue obj)
+{
+ return ttistable(obj);
+}
diff --git a/src/ktable.h b/src/ktable.h
@@ -37,4 +37,7 @@ void klispH_free (klisp_State *K, Table *t);
int32_t klispH_next (klisp_State *K, Table *t, TValue *key, TValue *data);
int32_t klispH_getn (Table *t);
+int32_t klispH_numuse(Table *t);
+bool ktablep(TValue obj);
+
#endif
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -702,6 +702,15 @@ void kwrite_scalar(klisp_State *K, TValue obj)
#endif
kw_printf(K, "]");
break;
+ case K_TTABLE:
+ kw_printf(K, "#[hash-table");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
case K_TLIBRARY:
kw_printf(K, "#[library");
#if KTRACK_NAMES
diff --git a/src/tests/tables.k b/src/tests/tables.k
@@ -0,0 +1,294 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of hash table features.
+;;
+
+;; XXX make-hash-table hash-table?
+
+($check-predicate (applicative? hash-table? make-hash-table))
+($check-predicate (hash-table?))
+($check-predicate (hash-table? (make-hash-table)))
+
+($check-not-predicate (hash-table? 0))
+($check-not-predicate (hash-table? ""))
+($check-not-predicate (hash-table? ()))
+($check-not-predicate (hash-table? (make-bytevector 0)))
+($check-not-predicate (hash-table? (make-vector 1)))
+($check-not-predicate (hash-table? (make-environment)))
+
+($check-error (make-hash-table eq?))
+($check-error (make-hash-table 32))
+($check-error (make-hash-table ($lambda (x) 1)))
+
+;; XXX hash-table-set! hash-table-ref hash-table-exists? hash-table-delete!
+
+($check-predicate
+ (applicative? hash-table-set! hash-table-ref
+ hash-table-exists? hash-table-delete!))
+
+($check equal?
+ ($let ((t (make-hash-table)))
+ (hash-table-set! t 0 "a")
+ (hash-table-set! t 1 "b")
+ (hash-table-set! t -30 "c")
+ (hash-table-set! t "x" "y")
+ (hash-table-set! t #\u 15)
+ (hash-table-set! t #:kwd 42)
+ (hash-table-set! t #t #f)
+ (hash-table-set! t #inert #\i)
+ (list
+ (map ($lambda (k) (hash-table-ref t k))
+ (list -30 #:kwd 0 1 #t #\u #inert))
+ (list
+ (hash-table-exists? t 0 1 #t)
+ (hash-table-exists? t)
+ (hash-table-exists? t #inert #ignore))))
+ (list
+ (list "c" 42 "a" "b" #f 15 #\i)
+ (list #t #t #f)))
+
+($check equal?
+ ($let ((t (make-hash-table)))
+ (hash-table-set! t 42 "a")
+ (hash-table-set! t 13 "b")
+ (hash-table-set! t -5 "c")
+ (hash-table-set! t 42 "d")
+ (hash-table-set! t 13 "e")
+ (list
+ (hash-table-ref t 13)
+ (hash-table-ref t 42)
+ (hash-table-exists? t 0)
+ (hash-table-exists? t -5)))
+ (list "e" "d" #f #t))
+
+($check equal?
+ ($let ((t (make-hash-table)))
+ (hash-table-set! t 42 "a")
+ (hash-table-delete! t 13)
+ (hash-table-delete! t 42 13)
+ (hash-table-set! t 13 "c")
+ (list (hash-table-ref t 13) (hash-table-exists? t 42)))
+ (list "c" #f))
+
+($check equal?
+ ($let
+ ((vx ($vau () denv ($binds? denv x)))
+ (vy ($vau () denv ($binds? denv y))))
+ ($let ((t (make-hash-table)) (x -5))
+ (list
+ (hash-table-ref t "a" ($lambda () "d"))
+ (hash-table-ref t "b" vx)
+ (hash-table-ref t "c" vy))))
+ (list "d" #t #f))
+
+($check-error (hash-table-ref (make-hash-table) 0))
+($check-error
+ ($let ((t (make-hash-table)))
+ (hash-table-set! t "a" "b")
+ (hash-table-ref t "b")))
+
+($let ((t (make-hash-table)))
+ (hash-table-set! t 3 "x")
+ ($check-error (hash-table-ref))
+ ($check-error (hash-table-ref () 2))
+ ($check-error (hash-table-ref t))
+ ($check-error (hash-table-ref t 2))
+ ($check-no-error (hash-table-ref t 3))
+ ($check-error (hash-table-ref t 3 5))
+ ($check-error (apply hash-table-ref (list* t 3 ($lambda () ()))))
+ ($check-error (hash-table-ref t 3 ($lambda () ()) 5))
+ ($check-error (hash-table-set!))
+ ($check-error (hash-table-set! t))
+ ($check-error (hash-table-set! t 1))
+ ($check-no-error (hash-table-set! t 1 2))
+ ($check-error (hash-table-set! () 1 2))
+ ($check-error (hash-table-set! t 1 3 4))
+ ($check-error (hash-table-exists?))
+ ($check-no-error (hash-table-exists? t))
+ ($check-error (hash-table-exists? ()))
+ ($check-error (hash-table-delete!))
+ ($check-error (hash-table-delete! () 1 2 3))
+ ($check-no-error (hash-table-delete! t)))
+
+;; XXX hash-table-length
+
+($check-predicate (applicative? hash-table-length))
+($check equal? (hash-table-length (make-hash-table)) 0)
+($check equal?
+ ($let ((t (make-hash-table)))
+ (hash-table-set! t "a" "b")
+ (hash-table-set! t "c" "d")
+ (hash-table-set! t "e" "f")
+ (hash-table-delete! t "c")
+ (hash-table-length t))
+ 2)
+($check-error (hash-table-length))
+($check-error (hash-table-length ()))
+($check-error (apply hash-table-length 1))
+($check-error (hash-table-length (make-hash-table) (make-hash-table)))
+
+;; XXX hash-table
+
+($check-predicate (applicative? hash-table))
+($check-predicate (hash-table? (hash-table)))
+($check equal?
+ ($let ((t (hash-table 0 #f 1 #t)))
+ (list
+ (hash-table? t)
+ (hash-table-length t)
+ (hash-table-exists? t 0)
+ (hash-table-exists? t 1)
+ (hash-table-exists? t 2)
+ (hash-table-ref t 0)
+ (hash-table-ref t 1)))
+ (list #t 2 #t #t #f #f #t))
+
+($check-error (hash-table 1))
+($check-error (hash-table 1 2 3))
+($check-error (hash-table 1 2 3 4 5))
+($check-error
+ ($let ((ls (list 1 2 3 4 5 6)))
+ (encycle! ls 3 3)
+ (apply hash-table ls)))
+
+;; XXX alist->hash-table
+
+($check-predicate (applicative? alist->hash-table))
+($check-predicate (hash-table? (alist->hash-table ())))
+($check equal?
+ ($let
+ ((t
+ (alist->hash-table
+ ($quote (("x" . "y") (1 . 2) (3 . 4))))))
+ (list
+ (hash-table? t)
+ (hash-table-length t)
+ (hash-table-exists? t "x")
+ (hash-table-exists? t "y")
+ (hash-table-exists? t 1)
+ (hash-table-exists? t 2)
+ (hash-table-ref t 1)
+ (hash-table-ref t 3)))
+ (list #t 3 #t #f #t #f 2 4))
+
+($check-no-error (alist->hash-table ()))
+($check-error (alist->hash-table))
+($check-error (alist->hash-table () ()))
+($check-error ((unwrap alist->hash-table) 0))
+($check-error (alist->hash-table 1))
+($check-error (alist->hash-table (list 1 2)))
+($check-error (alist->hash-table (list (cons 1 2) 3)))
+
+;; XXX hash-table-keys hash-table-values hash-table->alist
+
+($provide! (list-set-equal?)
+ ($define! list-subset?
+ ($lambda (a b)
+ ($if (null? a)
+ #t
+ ($and? (member? (car a) b) (list-subset? (cdr a) b)))))
+ ($define! list-set-equal?
+ ($lambda (a b)
+ ($and?
+ (=? (length a) (length b))
+ (list-subset? a b)
+ (list-subset? b a)))))
+
+($check-predicate
+ (applicative? hash-table-keys hash-table-values hash-table->alist))
+
+($check list-set-equal?
+ (hash-table-keys (hash-table "a" 1 "b" 2 "c" 3))
+ (list "a" "b" "c"))
+
+($check list-set-equal?
+ (hash-table-values (hash-table "a" 1 "b" 2 "c" 3))
+ (list 1 2 3))
+
+($check list-set-equal?
+ (hash-table->alist (hash-table "a" 1 "b" 2 "c" 3))
+ (list (cons "a" 1) (cons "b" 2) (cons "c" 3)))
+
+($let ((t (hash-table 1 2 3 4)))
+ ($check-error (hash-table-keys))
+ ($check-error (hash-table-keys ()))
+ ($check-error (hash-table-keys t t))
+ ($check-error (hash-table-values))
+ ($check-error (hash-table-values ()))
+ ($check-error (hash-table-values t t))
+ ($check-error (hash-table->alist))
+ ($check-error (hash-table->alist ()))
+ ($check-error (hash-table->alist t t)))
+
+;; XXX hash-table-merge hash-table-copy hash-table-merge!
+
+($check-predicate
+ (applicative? hash-table-merge hash-table-copy hash-table-merge!))
+
+($check equal?
+ (hash-table->alist (hash-table-merge))
+ ())
+
+($check list-set-equal?
+ (hash-table->alist
+ (hash-table-merge
+ (hash-table 1 "a" 2 "b")
+ (hash-table 1 "c" 3 "d")
+ (hash-table 1 "f" 5 "z")))
+ (list (cons 1 "f") (cons 2 "b") (cons 3 "d") (cons 5 "z")))
+
+($check list-set-equal?
+ (hash-table->alist
+ (hash-table-copy
+ (hash-table 1 "a" 2 "b")))
+ (list (cons 1 "a") (cons 2 "b")))
+
+($check list-set-equal?
+ ($let ((t (hash-table 1 "a" 2 "b")))
+ (hash-table-merge! t (hash-table "x" "y" 2 "w"))
+ (hash-table->alist t))
+ (list
+ (cons 1 "a") (cons 2 "w") (cons "x" "y")))
+
+($check equal?
+ ($let*
+ ((t1 (hash-table 1 "a" 2 "b"))
+ (t2 (hash-table 2 "c" 3 "d"))
+ (t3 (hash-table-merge t1 t2))
+ (t4 (hash-table-copy t2)))
+ (list
+ (eq? t1 t2) (eq? t1 t3) (eq? t1 t4)
+ (eq? t2 t3) (eq? t2 t4)
+ (eq? t3 t4)))
+ (list #f #f #f #f #f #f))
+
+($let*
+ ((t (hash-table 1 2 3 4))
+ (ls1 (list t))
+ (ls2 (list t t)))
+ (encycle! ls1 0 1)
+ (encycle! ls2 1 1)
+ ($check-no-error (hash-table-merge))
+ ($check-no-error (hash-table-merge t))
+ ($check-error (hash-table-merge t ()))
+ ($check-error (hash-table-merge () t))
+ ($check-no-error (hash-table-merge t t t t))
+ ($check-no-error (apply hash-table-merge ls1))
+ ($check-no-error (apply hash-table-merge ls2))
+ ($check-error ((unwrap hash-table-merge) 1))
+ ($check-error (hash-table-merge!))
+ ($check-no-error (hash-table-merge! t))
+ ($check-error (hash-table-merge! t ()))
+ ($check-error (hash-table-merge! () t))
+ ($check-no-error (hash-table-merge! t t t t))
+ ($check-no-error (apply hash-table-merge! ls1))
+ ($check-no-error (apply hash-table-merge! ls2))
+ ($check-error ((unwrap hash-table-merge!) 1))
+ ($check-error (hash-table-copy))
+ ($check-no-error (hash-table-copy t))
+ ($check-error (hash-table-copy t ()))
+ ($check-error (hash-table-copy () t))
+ ($check-no-error (apply hash-table-copy ls1))
+ ($check-error (apply hash-table-copy ls2))
+ ($check-error (hash-table-copy t t t t))
+ ($check-error ((unwrap hash-table-copy) 1)))
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -26,6 +26,7 @@
(load "tests/error.k")
(load "tests/bytevectors.k")
(load "tests/vectors.k")
+(load "tests/tables.k")
(load "tests/system.k")
(load "tests/keywords.k")
(load "tests/libraries.k")
