From 37178eacd51e06c7107a4be425f3a198b3f0b51d Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Tue, 18 Apr 2017 23:24:56 +0900
Subject: [PATCH] adding (srfi 125)

---
 lib/chibi/ast.c           |   9 +
 lib/chibi/ast.sld         |   2 +-
 lib/srfi/125.sld          |  38 +++
 lib/srfi/125/hash.scm     | 178 ++++++++++
 lib/srfi/125/test.sld     | 685 ++++++++++++++++++++++++++++++++++++++
 lib/srfi/69/interface.scm |  14 +-
 6 files changed, 921 insertions(+), 5 deletions(-)
 create mode 100644 lib/srfi/125.sld
 create mode 100644 lib/srfi/125/hash.scm
 create mode 100644 lib/srfi/125/test.sld

diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c
index f61a292b..edf62989 100644
--- a/lib/chibi/ast.c
+++ b/lib/chibi/ast.c
@@ -330,6 +330,14 @@ sexp sexp_immutablep_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_pointerp(x) ? sexp_make_boolean(sexp_immutablep(x)) : SEXP_TRUE;
 }
 
+sexp sexp_make_immutable_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+  if (sexp_pointerp(x)) {
+    sexp_immutablep(x) = 1;
+    return SEXP_TRUE;
+  }
+  return SEXP_FALSE;
+}
+
 sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
   sexp x = (sexp)sexp_unbox_fixnum(i);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
@@ -699,6 +707,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op);
   sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
   sexp_define_foreign(ctx, env, "immutable?", 1, sexp_immutablep_op);
+  sexp_define_foreign(ctx, env, "make-immutable!", 1, sexp_make_immutable_op);
   sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
   sexp_define_foreign_opt(ctx, env, "object->integer", 1, sexp_object_to_integer, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld
index 603ed313..46018cf9 100644
--- a/lib/chibi/ast.sld
+++ b/lib/chibi/ast.sld
@@ -39,7 +39,7 @@
    atomically thread-list abort
    string-contains string-cursor-copy! errno integer->error-string
    flatten-dot update-free-vars! setenv unsetenv safe-setenv
-   immutable?)
+   immutable? make-immutable!)
   (import (chibi))
   (include-shared "ast")
   (include "ast.scm"))
diff --git a/lib/srfi/125.sld b/lib/srfi/125.sld
new file mode 100644
index 00000000..c1d7813f
--- /dev/null
+++ b/lib/srfi/125.sld
@@ -0,0 +1,38 @@
+(define-library (srfi 125)
+  (import (scheme base)
+          (srfi 128)
+          (rename (srfi 69)
+                  (make-hash-table %make-hash-table)
+                  (alist->hash-table %alist->hash-table)
+                  (hash-table-copy %hash-table-copy)
+                  (hash-table-set! %hash-table-set!)
+                  (hash-table-delete! %hash-table-delete!)
+                  (hash-table-fold %hash-table-fold))
+          (only (chibi ast) immutable? make-immutable!))
+  (export
+   ;; Constructors:
+   make-hash-table hash-table hash-table-unfold alist->hash-table
+   ;; Predicates:
+   hash-table? hash-table-contains? hash-table-exists?
+   hash-table-empty? hash-table=? hash-table-mutable?
+   ;; Accessors:
+   hash-table-ref hash-table-ref/default
+   ;; Mutators:
+   hash-table-set! hash-table-delete! hash-table-intern!
+   hash-table-update! hash-table-update!/default hash-table-pop!
+   hash-table-clear!
+   ;; The whole hash table:
+   hash-table-size hash-table-keys hash-table-values
+   hash-table-entries hash-table-find hash-table-count
+   ;; Mapping and folding:
+   hash-table-map hash-table-for-each hash-table-walk
+   hash-table-map! hash-table-map->list hash-table-fold hash-table-prune!
+   ;; Copying and conversion:
+   hash-table-copy hash-table-empty-copy hash-table->alist
+   ;; Hash tables as sets:
+   hash-table-union! hash-table-merge!
+   hash-table-intersection! hash-table-difference! hash-table-xor!
+   ;; Hash functions and reflectivity:
+   hash string-hash string-ci-hash hash-by-identity
+   hash-table-equivalence-function hash-table-hash-function)
+  (include "125/hash.scm"))
diff --git a/lib/srfi/125/hash.scm b/lib/srfi/125/hash.scm
new file mode 100644
index 00000000..891351cb
--- /dev/null
+++ b/lib/srfi/125/hash.scm
@@ -0,0 +1,178 @@
+
+(define (opt-hash eq-fn o)
+  (if (pair? o)
+      (car o)
+      (if (eq? eq? eq-fn) hash-by-identity hash)))
+
+(define (make-hash-table x . o)
+  (if (comparator? x)
+      (%make-hash-table (comparator-equality-predicate x)
+                        (comparator-hash-function x))
+      (%make-hash-table x (opt-hash x o))))
+
+(define (hash-table comparator . o)
+  (let ((ht (make-hash-table comparator)))
+    (let lp ((ls o))
+      (when (pair? ls)
+        (hash-table-set! ht (car ls) (cadr ls))
+        (lp (cddr ls))))
+    ht))
+
+(define (hash-table-copy ht . o)
+  (cond
+   ((and (pair? o) (car o))
+    (%hash-table-copy ht))
+   ((hash-table-mutable? ht)
+    (let ((res (%hash-table-copy ht)))
+      (make-immutable! res)
+      res))
+   (else
+    ht)))
+
+(define (hash-table-set! ht . o)
+  (let lp ((ls o))
+    (when (pair? ls)
+      (%hash-table-set! ht (car ls) (cadr ls))
+      (lp (cddr ls)))))
+
+(define (hash-table-fold a b c)
+  (if (hash-table? a)
+      (%hash-table-fold a b c)
+      (%hash-table-fold c a b)))
+
+(define (hash-table-unfold stop? mapper successor seed comparator . o)
+  (let ((ht (make-hash-table comparator)))
+    (let lp ((acc seed))
+      (if (stop? acc)
+          ht
+          (call-with-values (lambda () (mapper acc))
+            (lambda (key value)
+              (hash-table-set! ht key value)
+              (lp (successor acc))))))))
+
+(define (alist->hash-table alist x . o)
+  (if (comparator? x)
+      (%alist->hash-table alist
+                          (comparator-equality-predicate x)
+                          (comparator-hash-function x))
+      (%alist->hash-table alist x (opt-hash x o))))
+
+(define hash-table-contains? hash-table-exists?)
+
+(define (hash-table-empty? ht)
+  (zero? (hash-table-size ht)))
+
+(define (hash-table-mutable? ht)
+  (not (immutable? ht)))
+
+(define missing-key (list 'missing-key))
+
+(define (hash-table=? value-cmp ht1 ht2)
+  (and (= (hash-table-size ht1)
+          (hash-table-size ht2))
+       (let lp ((ls (hash-table-keys ht1)))
+         (or (null? ls)
+             (let ((v1 (hash-table-ref/default ht1 (car ls) missing-key))
+                   (v2 (hash-table-ref/default ht2 (car ls) missing-key)))
+               (and (not (eq? missing-key v1))
+                    (not (eq? missing-key v2))
+                    ((comparator-equality-predicate value-cmp) v1 v2)
+                    (lp (cdr ls))))))))
+
+(define (hash-table-intern! ht key failure)
+  (hash-table-ref ht key (lambda ()
+                           (let ((res (failure)))
+                             (hash-table-set! ht key res)
+                             res))))
+
+(define (hash-table-delete! ht . keys)
+  (for-each (lambda (key) (%hash-table-delete! ht key)) keys))
+
+(define (hash-table-pop! ht)
+  (let* ((key (car (hash-table-keys ht)))
+         (value (hash-table-ref ht key)))
+    (hash-table-delete! ht key)
+    (values key value)))
+
+(define (hash-table-clear! ht)
+  (for-each
+   (lambda (key) (hash-table-delete! ht key))
+   (hash-table-keys ht)))
+
+(define (hash-table-entries ht)
+  (values (hash-table-keys ht) (hash-table-values ht)))
+
+(define (hash-table-find proc ht failure)
+  (call-with-current-continuation
+   (lambda (return)
+     (hash-table-for-each
+      (lambda (key value)
+        (let ((res (proc key value)))
+          (if res (return res))))
+      ht)
+     (failure))))
+
+(define (hash-table-count proc ht)
+  (let ((count 0))
+    (hash-table-for-each
+     (lambda (key value)
+       (if (proc key value)
+           (set! count (+ count 1))))
+     ht)
+    count))
+
+(define (hash-table-map proc cmp ht)
+  (let ((ht2 (make-hash-table cmp)))
+    (hash-table-for-each
+     (lambda (key value) (hash-table-set! ht2 key (proc value)))
+     ht)
+    ht2))
+
+(define (hash-table-map! proc ht)
+  (for-each
+   (lambda (key value) (hash-table-set! ht key (proc key value)))
+   (hash-table-keys ht)
+   (hash-table-values ht)))
+
+(define (hash-table-for-each proc ht)
+  (hash-table-walk ht proc))
+
+(define (hash-table-map->list proc ht)
+  (map (lambda (cell) (proc (car cell) (cdr cell))) (hash-table->alist ht)))
+
+(define (hash-table-prune! proc ht)
+  (for-each
+   (lambda (key value)
+     (if (proc key value)
+         (hash-table-delete! ht key)))
+   (hash-table-keys ht)
+   (hash-table-values ht)))
+
+(define (hash-table-empty-copy ht)
+  (make-hash-table (hash-table-equivalence-function ht)
+                   (hash-table-hash-function ht)))
+
+(define hash-table-union! hash-table-merge!)
+
+(define (hash-table-intersection! ht1 ht2)
+  (for-each
+   (lambda (key)
+     (if (not (hash-table-contains? ht2 key))
+         (hash-table-delete! ht1 key)))
+   (hash-table-keys ht1))
+  ht1)
+
+(define (hash-table-difference! ht1 ht2)
+  (for-each
+   (lambda (key)
+     (if (hash-table-contains? ht2 key)
+         (hash-table-delete! ht1 key)))
+   (hash-table-keys ht1))
+  ht1)
+
+(define (hash-table-xor! ht1 ht2)
+  (let* ((tmp (hash-table-copy ht1 #t))
+         (intersection (hash-table-intersection! tmp ht2)))
+    (hash-table-difference! (hash-table-union! ht1 ht2)
+                            intersection)
+    ht1))
diff --git a/lib/srfi/125/test.sld b/lib/srfi/125/test.sld
new file mode 100644
index 00000000..3265f243
--- /dev/null
+++ b/lib/srfi/125/test.sld
@@ -0,0 +1,685 @@
+(define-library (srfi 125 test)
+  (export run-tests)
+  (import (scheme base) (scheme char) (scheme write)
+          (srfi 125) (srfi 128) (srfi 132)
+          (chibi test))
+  (begin
+    (define (run-tests)
+      (define default-comparator (make-default-comparator))
+      (define number-comparator
+        (make-comparator real? = < (lambda (x . o) (exact (abs (round x))))))
+      (define string-comparator
+        (make-comparator string? string=? string<? string-hash))
+      (define string-ci-comparator
+        (make-comparator string? string-ci=? string-ci<? string-ci-hash))
+      (define eq-comparator (make-eq-comparator))
+      (define eqv-comparator (make-eqv-comparator))
+      (define ht-default (make-hash-table default-comparator))
+      (define ht-eq (make-hash-table eq-comparator 'random-argument "another"))
+      (define ht-eqv (make-hash-table eqv-comparator))
+      (define ht-eq2 (make-hash-table eq?))
+      (define ht-eqv2 (make-hash-table eqv?))
+      (define ht-equal (make-hash-table equal?))
+      (define ht-string (make-hash-table string=?))
+      (define ht-string-ci (make-hash-table string-ci=?))
+      (define ht-symbol (make-hash-table symbol=?))    ; FIXME: glass-box
+      (define ht-fixnum (make-hash-table = (lambda (x . o) (abs x))))
+      (define ht-default2
+        (hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#()))
+      (define ht-fixnum2
+        (let ((ht (make-hash-table number-comparator)))
+          (do ((i 0 (+ i 1)))
+              ((= i 10) (hash-table-copy ht))
+            (hash-table-set! ht (* i i) i))))
+      (define ht-string2
+        (hash-table-unfold (lambda (s) (= 0 (string-length s)))
+                           (lambda (s) (values s (string-length s)))
+                           (lambda (s) (substring s 0 (- (string-length s) 1)))
+                           "prefixes"
+                           string-comparator
+                           'ignored1 'ignored2 "ignored3" '#(ignored 4 5)))
+      (define ht-string-ci2
+        (alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5))
+                           string-ci-comparator
+                           "ignored1" 'ignored2))
+      (define ht-symbol2
+        (alist->hash-table '((mary . travers) (noel . stookey) (peter .yarrow))
+                           eq?))
+      (define ht-equal2
+        (alist->hash-table '(((edward) . abbey)
+                             ((dashiell) . hammett)
+                             ((edward) . teach)
+                             ((mark) . twain))
+                           equal?
+                           (comparator-hash-function default-comparator)))
+      (define test-tables
+        (list ht-default   ht-default2   ; initial keys: foo, 101.3, (x y z)
+              ht-eq        ht-eq2        ; initially empty
+              ht-eqv       ht-eqv2       ; initially empty
+              ht-equal     ht-equal2     ; initial keys: (edward), (dashiell), (mark)
+              ht-string    ht-string2    ; initial keys: "p, "pr", ..., "prefixes"
+              ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter"
+              ht-symbol    ht-symbol2    ; initial keys: mary, noel, peter
+              ht-fixnum    ht-fixnum2))  ; initial keys: 0, 1, 4, 9, ..., 81
+
+      (test-begin "srfi 125: intermediate hash tables")
+
+      ;; Predicates
+
+      (test (append '(#f #f) (map (lambda (x) #t) test-tables))
+          (map hash-table?
+               (cons '#()
+                     (cons default-comparator
+                           test-tables))))
+
+      (test '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t)
+          (map hash-table-contains?
+               test-tables
+               '(foo 101.3
+                     x "y"
+                     (14 15) #\newline
+                     (edward) (mark)
+                     "p" "pref"
+                     "mike" "PAUL"
+                     jane noel
+                     0 4)))
+
+      (test (map (lambda (x) #f) test-tables)
+          (map hash-table-contains?
+               test-tables
+               '(#u8() 47.9
+                    '#() '()
+                    foo bar
+                    19 (henry)
+                    "p" "perp"
+                    "mike" "Noel"
+                    jane paul
+                    0 5)))
+
+      (test '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f)
+          (map hash-table-empty? test-tables))
+
+      ;; (test (map (lambda (x) #t) test-tables)
+      ;;     (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+      ;;          test-tables
+      ;;          test-tables))
+
+      ;; (test '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f)
+      ;;     (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+      ;;          test-tables
+      ;;          (do ((tables (reverse test-tables) (cddr tables))
+      ;;               (rev '() (cons (car tables) (cons (cadr tables) rev))))
+      ;;              ((null? tables)
+      ;;               rev))))
+
+      (test '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f)
+          (map hash-table-mutable? test-tables))
+
+      ;; FIXME: glass-box
+      ;; (test (map hash-table-mutable? (map hash-table-copy test-tables))
+      ;;     (map (lambda (x) #f) test-tables))
+
+      (test #t
+          (hash-table-mutable? (hash-table-copy ht-fixnum2 #t)))
+
+      ;; Accessors.
+
+      ;; FIXME: glass-box (implementations not required to raise an exception here)
+      ;; (test (map (lambda (ht)
+      ;;              (guard (exn
+      ;;                      (else 'err))
+      ;;                (hash-table-ref ht 'not-a-key)))
+      ;;            test-tables)
+      ;;     (map (lambda (ht) 'err) test-tables))
+
+      ;; FIXME: glass-box (implementations not required to raise an exception here)
+      ;; (test (map (lambda (ht)
+      ;;              (guard (exn
+      ;;                      (else 'err))
+      ;;                (hash-table-ref ht 'not-a-key (lambda () 'err))))
+      ;;            test-tables)
+      ;;     (map (lambda (ht) 'err) test-tables))
+
+      ;; FIXME: glass-box (implementations not required to raise an exception here)
+      ;; (test (map (lambda (ht)
+      ;;              (guard (exn
+      ;;                      (else 'err))
+      ;;                (hash-table-ref ht 'not-a-key (lambda () 'err) values)))
+      ;;            test-tables)
+      ;;     (map (lambda (ht) 'err) test-tables))
+
+      (test '(err "fever" err err err err err twain err 4 err 4 err stookey err 2)
+          (map (lambda (ht key)
+                 (guard (exn
+                         (else 'err))
+                   (hash-table-ref ht key)))
+               test-tables
+               '(foo 101.3
+                     x "y"
+                     (14 15) #\newline
+                     (edward) (mark)
+                     "p" "pref"
+                     "mike" "PAUL"
+                     jane noel
+                     0 4)))
+
+      (test '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)
+          (map (lambda (ht key)
+                 (guard (exn
+                         (else 'err))
+                   (hash-table-ref ht key (lambda () 'eh))))
+               test-tables
+               '(foo 101.3
+                     x "y"
+                     (14 15) #\newline
+                     (edward) (mark)
+                     "p" "pref"
+                     "mike" "PAUL"
+                     jane noel
+                     0 4)))
+
+      (test '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2))
+          (map (lambda (ht key)
+                 (guard (exn
+                         (else 'err))
+                   (hash-table-ref ht key (lambda () 'eh) list)))
+               test-tables
+               '(foo 101.3
+                     x "y"
+                     (14 15) #\newline
+                     (edward) (mark)
+                     "p" "pref"
+                     "mike" "PAUL"
+                     jane noel
+                     0 4)))
+
+      ;; FIXME: glass-box (implementations not required to raise an exception here)
+      ;; (test (map (lambda (ht)
+      ;;              (guard (exn
+      ;;                      (else 'eh))
+      ;;                (hash-table-ref/default ht 'not-a-key 'eh)))
+      ;;            test-tables)
+      ;;     (map (lambda (ht) 'eh) test-tables))
+
+      (test '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)
+          (map (lambda (ht key)
+                 (guard (exn
+                         (else 'err))
+                   (hash-table-ref/default ht key 'eh)))
+               test-tables
+               '(foo 101.3
+                     x "y"
+                     (14 15) #\newline
+                     (edward) (mark)
+                     "p" "pref"
+                     "mike" "PAUL"
+                     jane noel
+                     0 4)))
+
+      (test '()
+          (begin (hash-table-set! ht-fixnum)
+                 (list-sort < (hash-table-keys ht-fixnum))))
+
+      (test '(121 144 169)
+          (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13)
+                 (list-sort < (hash-table-keys ht-fixnum))))
+
+      (test '(0 1 4 9 16 25 36 49 64 81 121 144 169)
+          (begin (hash-table-set! ht-fixnum
+                                  0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9)
+                 (list-sort < (hash-table-keys ht-fixnum))))
+
+      (test '(13 12 11 0 1 2 3 4 5 6 7 8 9)
+          (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+               '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+
+      (test '(13 12 11 0 1 2 3 4 5 6 7 8 9)
+          (begin (hash-table-delete! ht-fixnum)
+                 (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+                      '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+      (test '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1)
+          (begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1)
+                 (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                      '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+      (test '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1)
+          (begin (hash-table-delete! ht-fixnum 200 100 0 81 36)
+                 (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                      '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+      (test '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1)
+          (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+                 (hash-table-intern! ht-fixnum 121 (lambda () 11))
+                 (hash-table-intern! ht-fixnum   0 (lambda ()  0))
+                 (hash-table-intern! ht-fixnum   1 (lambda ()  1))
+                 (hash-table-intern! ht-fixnum   1 (lambda () 99))
+                 (hash-table-intern! ht-fixnum 121 (lambda () 66))
+                 (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                      '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+      (test '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13))
+          (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0)))
+                     (hash-table-map->list vector ht-fixnum)))
+
+      (test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+                   (hash-table-intern! ht-fixnum 144 (lambda () 9999))
+                   (hash-table-intern! ht-fixnum 121 (lambda () 11))
+                   (list-sort (lambda (l1 l2)
+                                (< (car l1) (car l2)))
+                              (hash-table-map->list list ht-fixnum)))
+          '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13)))
+
+      (test (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c)))
+                   (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                        '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+          '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+      (test (begin (hash-table-update! ht-fixnum 16 -)
+                   (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                        '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+          '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1))
+
+      (test (begin (hash-table-update! ht-fixnum 16 - abs)
+                   (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                        '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+          '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+      (test (begin (hash-table-update!/default ht-fixnum 25 - 5)
+                   (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                        '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+          '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1))
+
+      (test (begin (hash-table-update!/default ht-fixnum 25 - 999)
+                   (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                        '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+          '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
+
+      (test '(#t #t)
+          (let* ((n0 (hash-table-size ht-fixnum))
+                 (ht (hash-table-copy ht-fixnum #t)))
+            (call-with-values
+                (lambda () (hash-table-pop! ht))
+              (lambda (key val)
+                (list (= key (* val val))
+                      (= (- n0 1) (hash-table-size ht)))))))
+
+      (test '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1)
+          (begin (hash-table-delete! ht-fixnum 75)
+                 (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                      '(169 144 121 0 1 4 9 16 25 36 49 64 75 81))))
+
+      (test '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)
+          (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+               '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+
+      (test '(13 12 11 0 1 2 3 4 5 6 -1 8 9)
+          (begin (hash-table-set! ht-fixnum 36 6)
+                 (hash-table-set! ht-fixnum 81 9)
+                 (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                      '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+      (test 0
+          (begin (hash-table-clear! ht-eq)
+                 (hash-table-size ht-eq)))
+
+      ;; The whole hash table.
+
+      (test 3
+          (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18)
+                 (hash-table-size ht-eq)))
+
+      (test '(0 3 #t)
+          (let* ((ht (hash-table-empty-copy ht-eq))
+                 (n0 (hash-table-size ht))
+                 (ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18))
+                 (n1 (hash-table-size ht)))
+            (list n0 n1 (hash-table=? default-comparator ht ht-eq))))
+
+      (test 0
+          (begin (hash-table-clear! ht-eq)
+                 (hash-table-size ht-eq)))
+
+      (test '(144 12)
+          (hash-table-find (lambda (key val)
+                             (if (= 144 key (* val val))
+                                 (list key val)
+                                 #f))
+                           ht-fixnum
+                           (lambda () 99)))
+
+      (test 99
+          (hash-table-find (lambda (key val)
+                             (if (= 144 key val)
+                                 (list key val)
+                                 #f))
+                           ht-fixnum
+                           (lambda () 99)))
+
+      (test 2
+          (hash-table-count <= ht-fixnum))
+
+      ;; Mapping and folding.
+
+      (test '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)
+          (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+               '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+
+      (test '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
+          (let ((ht (hash-table-map (lambda (val) (* val val))
+                                    eqv-comparator
+                                    ht-fixnum)))
+            (map (lambda (i) (hash-table-ref/default ht i -1))
+                 '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))))
+
+      (test '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
+              #(0 1 2 3  4  5  6 -1  8  9 -1  11  12  13 -1))
+          (let ((keys (make-vector 15 -1))
+                (vals (make-vector 15 -1)))
+            (hash-table-for-each (lambda (key val)
+                                   (vector-set! keys val key)
+                                   (vector-set! vals val val))
+                                 ht-fixnum)
+            (list keys vals)))
+
+      (test '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1)
+          (begin (hash-table-map! (lambda (key val)
+                                    (if (<= 10 key)
+                                        (- val)
+                                        val))
+                                  ht-fixnum)
+                 (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                      '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))))
+
+      (test 13
+          (hash-table-fold (lambda (key val acc)
+                             (+ val acc))
+                           0
+                           ht-string-ci2))
+
+      (test '(0 1 4 9 16 25 36 64 81 121 144 169)
+          (list-sort < (hash-table-fold (lambda (key val acc)
+                                          (cons key acc))
+                                        '()
+                                        ht-fixnum)))
+
+      ;; Copying and conversion.
+
+      (test #t
+          (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum)))
+
+      (test #t
+          (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f)))
+
+      (test #t
+          (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t)))
+
+      (test #f
+          (hash-table-mutable? (hash-table-copy ht-fixnum)))
+
+      (test #f
+          (hash-table-mutable? (hash-table-copy ht-fixnum #f)))
+
+      (test #t
+          (hash-table-mutable? (hash-table-copy ht-fixnum #t)))
+
+      (test '()
+          (hash-table->alist ht-eq))
+
+      (test '((0 . 0)
+              (1 . 1)
+              (4 . 2)
+              (9 . 3)
+              (16 . -4)
+              (25 . -5)
+              (36 . -6)
+              (64 . -8)
+              (81 . -9)
+              (121 . -11)
+              (144 . -12)
+              (169 . -13))
+          (list-sort (lambda (x y) (< (car x) (car y)))
+                     (hash-table->alist ht-fixnum)))
+
+      ;; Hash tables as sets.
+
+      (test '((0 . 0)
+              (1 . 1)
+              (4 . 2)
+              (9 . 3)
+              (16 . -4)
+              (25 . -5)
+              (36 . -6)
+              (49 . 7)
+              (64 . -8)
+              (81 . -9)
+              (121 . -11)
+              (144 . -12)
+              (169 . -13))
+          (begin (hash-table-union! ht-fixnum ht-fixnum2)
+                 (list-sort (lambda (x y) (< (car x) (car y)))
+                            (hash-table->alist ht-fixnum))))
+
+      (test '((0 . 0)
+              (1 . 1)
+              (4 . 2)
+              (9 . 3)
+              (16 . 4)
+              (25 . 5)
+              (36 . 6)
+              (49 . 7)
+              (64 . 8)
+              (81 . 9)
+              (121 . -11)
+              (144 . -12)
+              (169 . -13))
+          (let ((ht (hash-table-copy ht-fixnum2 #t)))
+            (hash-table-union! ht ht-fixnum)
+            (list-sort (lambda (x y) (< (car x) (car y)))
+                       (hash-table->alist ht))))
+
+      (test #t
+          (begin (hash-table-union! ht-eqv2 ht-fixnum)
+                 (hash-table=? default-comparator ht-eqv2 ht-fixnum)))
+
+      (test #t
+          (begin (hash-table-intersection! ht-eqv2 ht-fixnum)
+                 (hash-table=? default-comparator ht-eqv2 ht-fixnum)))
+
+      (test #t
+          (begin (hash-table-intersection! ht-eqv2 ht-eqv)
+                 (hash-table-empty? ht-eqv2)))
+
+      (test '((0 . 0)
+              (1 . 1)
+              (4 . 2)
+              (9 . 3)
+              (16 . -4)
+              (25 . -5)
+              (36 . -6)
+              (49 . 7)
+              (64 . -8)
+              (81 . -9))
+          (begin (hash-table-intersection! ht-fixnum ht-fixnum2)
+                 (list-sort (lambda (x y) (< (car x) (car y)))
+                            (hash-table->alist ht-fixnum))))
+
+      (test '((4 . 2)
+              (25 . -5))
+          (begin (hash-table-intersection!
+                  ht-fixnum
+                  (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+                                     number-comparator))
+                 (list-sort (lambda (x y) (< (car x) (car y)))
+                            (hash-table->alist ht-fixnum))))
+
+      (test '((0 . 0)
+              (1 . 1)
+              (9 . 3)
+              (16 . 4)
+              (36 . 6)
+              (49 . 7)
+              (64 . 8)
+              (81 . 9))
+          (let ((ht (hash-table-copy ht-fixnum2 #t)))
+            (hash-table-difference!
+             ht
+             (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+                                number-comparator))
+            (list-sort (lambda (x y) (< (car x) (car y)))
+                       (hash-table->alist ht))))
+
+      (test '((-1 . -1)
+              (0 . 0)
+              (1 . 1)
+              (9 . 3)
+              (16 . 4)
+              (36 . 6)
+              (49 . 7)
+              (64 . 8)
+              (81 . 9)
+              (100 . 10))
+          (let ((ht (hash-table-copy ht-fixnum2 #t)))
+            (hash-table-xor!
+             ht
+             (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+                                number-comparator))
+            (list-sort (lambda (x y) (< (car x) (car y)))
+                       (hash-table->alist ht))))
+
+      (test 'key-not-found
+          (guard (exn
+                  (else 'key-not-found))
+            (hash-table-ref ht-default "this key won't be present")))
+
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+      ;;
+      ;; Desultory tests of deprecated procedures and usages.
+      ;; Deprecated usage of make-hash-table and alist->hash-table
+      ;; has already been tested above.
+      ;;
+      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+      (test '(#t #t #t)
+          (let* ((x (list 1 2 3))
+                 (y (cons 1 (cdr x)))
+                 (h1 (hash x))
+                 (h2 (hash y)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test '(#t #t #t)
+          (let* ((x "abcd")
+                 (y (string-append "ab" "cd"))
+                 (h1 (string-hash x))
+                 (h2 (string-hash y)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test '(#t #t #t)
+          (let* ((x "Hello There!")
+                 (y "hello THERE!")
+                 (h1 (string-ci-hash x))
+                 (h2 (string-ci-hash y)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test '(#t #t #t)
+          (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+                 (y x)
+                 (h1 (hash-by-identity x))
+                 (h2 (hash-by-identity y)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test '(#t #t #t)
+          (let* ((x (list 1 2 3))
+                 (y (cons 1 (cdr x)))
+                 (h1 (hash x 60))
+                 (h2 (hash y 60)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test '(#t #t #t)
+          (let* ((x "abcd")
+                 (y (string-append "ab" "cd"))
+                 (h1 (string-hash x 97))
+                 (h2 (string-hash y 97)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test '(#t #t #t)
+          (let* ((x "Hello There!")
+                 (y "hello THERE!")
+                 (h1 (string-ci-hash x 101))
+                 (h2 (string-ci-hash y 101)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test '(#t #t #t)
+          (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+                 (y x)
+                 (h1 (hash-by-identity x 102))
+                 (h2 (hash-by-identity y 102)))
+            (list (exact-integer? h1)
+                  (exact-integer? h2)
+                  (= h1 h2))))
+
+      (test #t
+          (let ((f (hash-table-equivalence-function ht-fixnum)))
+            (if (procedure? f)
+                (f 34 34)
+                #t)))
+
+      (test #t
+          (let ((f (hash-table-hash-function ht-fixnum)))
+            (if (procedure? f)
+                (= (f 34) (f 34))
+                #t)))
+
+      (test '(#t #t #f #f #t #f #f #f #f #t #f)
+          (map (lambda (key) (hash-table-exists? ht-fixnum2 key))
+               '(0 1 2 3 4 5 6 7 8 9 10)))
+
+      (test (apply +
+                   (map (lambda (x) (* x x))
+                        '(0 1 2 3 4 5 6 7 8 9)))
+          (let ((n 0))
+            (hash-table-walk ht-fixnum2
+                             (lambda (key val) (set! n (+ n key))))
+            n))
+
+      (test '(0 1 4 9 16 25 36 49 64 81)
+          (list-sort < (hash-table-fold ht-fixnum2
+                                        (lambda (key val acc)
+                                          (cons key acc))
+                                        '())))
+
+      (test '((0 . 0)
+              (.25 . .5)
+              (1 . 1)
+              (4 . 2)
+              (9 . 3)
+              (16 . 4)
+              (25 . 5)
+              (36 . 6)
+              (49 . 7)
+              (64 . 8)
+              (81 . 9)
+              (121 . -11)
+              (144 . -12))
+          (let ((ht (hash-table-copy ht-fixnum2 #t))
+                (ht2 (hash-table number-comparator
+                                 .25 .5 64 9999 81 9998 121 -11 144 -12)))
+            (hash-table-merge! ht ht2)
+            (list-sort (lambda (x y) (< (car x) (car y)))
+                       (hash-table->alist ht))))
+
+      (test-end))))
diff --git a/lib/srfi/69/interface.scm b/lib/srfi/69/interface.scm
index 99bfc9f7..d0ce8eef 100644
--- a/lib/srfi/69/interface.scm
+++ b/lib/srfi/69/interface.scm
@@ -1,5 +1,5 @@
 ;; interface.scm -- hash-table interface
-;; Copyright (c) 2009-2011 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2009-2017 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;; the non-exported hash-table-cell is the heart of the implemenation
@@ -38,7 +38,9 @@
 (define (hash-table-ref table key . o)
   (assert-hash-table "hash-table-ref" table)
   (let ((cell (hash-table-cell table key #f)))
-    (cond (cell (cdr cell))
+    (cond (cell (if (and (pair? o) (pair? (cdr o)))
+                    ((cadr o) (cdr cell))
+                    (cdr cell)))
           ((pair? o) ((car o)))
           (else (error "hash-table-ref: key not found" key)))))
 
@@ -65,7 +67,9 @@
                            (if (pair? o)
                                (func ((car o)))
                                (error "hash-table-update!: key not found" key))
-                           (func (cdr cell))))))))
+                           (func (if (and (pair? o) (pair? (cdr o)))
+                                     ((cadr o) (cdr cell))
+                                     (cdr cell)))))))))
 
 (define hash-table-update!/default
   (let ((not-found (cons 'not-found '())))
@@ -106,7 +110,9 @@
     res))
 
 (define (hash-table-merge! a b)
-  (hash-table-walk b (lambda (k v) (hash-table-set! a k v)))
+  (hash-table-walk b (lambda (k v)
+                       (if (not (hash-table-exists? a k))
+                           (hash-table-set! a k v))))
   a)
 
 (define (hash-table-copy table)