├── .github └── workflows │ ├── force-native.lisp │ ├── github-workflow-tests.lisp │ └── run-tests.yaml ├── README.md ├── cl-custom-hash-table-test.asd ├── cl-custom-hash-table.asd ├── custom-hash-table.lisp ├── package.lisp ├── test-package.lisp └── test-suite.lisp /.github/workflows/force-native.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (setf *features* 5 | (cons :custom-hash-table-fallback 6 | (remove :custom-hash-table-native *features*)))) 7 | -------------------------------------------------------------------------------- /.github/workflows/github-workflow-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (load "/tmp/ql-dir/quicklisp.lisp") 4 | (quicklisp-quickstart:install) 5 | 6 | (load "/home/runner/work/cl-custom-hash-table/cl-custom-hash-table/cl-custom-hash-table.asd") 7 | (load "/home/runner/work/cl-custom-hash-table/cl-custom-hash-table/cl-custom-hash-table-test.asd") 8 | 9 | (ql:quickload :cl-custom-hash-table) 10 | (ql:quickload :cl-custom-hash-table-test) 11 | 12 | (asdf:oos 'asdf::load-op :cl-custom-hash-table :force t) 13 | (asdf:oos 'asdf::load-op :cl-custom-hash-table-test :force t) 14 | 15 | (cl-custom-hash-table-test:run-without-debugging) 16 | -------------------------------------------------------------------------------- /.github/workflows/run-tests.yaml: -------------------------------------------------------------------------------- 1 | name: build & test 2 | on: 3 | push: 4 | branches: 5 | - master 6 | - dev 7 | jobs: 8 | 9 | install_ecl: 10 | name: Download ECL 11 | runs-on: ubuntu-latest 12 | steps: 13 | - run: | 14 | cd /tmp 15 | mkdir ecl-dir 16 | cd ecl-dir 17 | wget https://common-lisp.s3.eu-central-1.amazonaws.com/ecl-23.9.9.tgz 18 | - name: Upload ECL artifact 19 | uses: actions/upload-artifact@v4 20 | with: 21 | name: ecl-artifact 22 | path: /tmp/ecl-dir/ecl-23.9.9.tgz 23 | 24 | install_quicklisp: 25 | name: Install QuickLisp 26 | runs-on: ubuntu-latest 27 | steps: 28 | - run: | 29 | cd /tmp 30 | mkdir ql-dir 31 | cd ql-dir 32 | wget -q https://beta.quicklisp.org/quicklisp.lisp 33 | chmod -R a+rwx /tmp/ql-dir 34 | - name: Upload Quicklisp artifact 35 | uses: actions/upload-artifact@v4 36 | with: 37 | name: ql-artifact 38 | path: /tmp/ql-dir 39 | 40 | run_test_suites: 41 | name: Test on ${{ matrix.scenario }} 42 | runs-on: ubuntu-latest 43 | strategy: 44 | matrix: 45 | scenario: [ecl_native, ecl_fallback, sbcl_native, sbcl_fallback, clisp_native, clisp_fallback] 46 | needs: [install_quicklisp] 47 | steps: 48 | - uses: actions/checkout@v4 49 | - run: | 50 | cd /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/ 51 | cat force-native.lisp github-workflow-tests.lisp > github-workflow-tests-fallback.lisp 52 | - uses: actions/download-artifact@v4 53 | with: 54 | name: ql-artifact 55 | path: /tmp/ql-dir 56 | - if: (matrix.scenario == 'ecl_native') || (matrix.scenario == 'ecl_fallback') 57 | uses: actions/download-artifact@v4 58 | with: 59 | name: ecl-artifact 60 | path: /tmp/ecl-dir/ 61 | - if: (matrix.scenario == 'ecl_native') || (matrix.scenario == 'ecl_fallback') 62 | run: | 63 | cd /tmp/ecl-dir/ 64 | tar -xzf ecl-23.9.9.tgz 65 | cd ecl-23.9.9 66 | ./configure 67 | make -j 8 68 | sudo make install 69 | - if: matrix.scenario == 'ecl_native' 70 | run: | 71 | ecl --shell /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests.lisp 72 | - if: matrix.scenario == 'ecl_fallback' 73 | run: | 74 | ecl --shell /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests-fallback.lisp 75 | 76 | - if: (matrix.scenario == 'sbcl_native') || (matrix.scenario == 'sbcl_fallback') 77 | run: | 78 | sudo apt-get install sbcl 79 | - if: matrix.scenario == 'sbcl_native' 80 | run: | 81 | sbcl --script /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests.lisp 82 | - if: matrix.scenario == 'sbcl_fallback' 83 | run: | 84 | sbcl --script /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests-fallback.lisp 85 | 86 | - if: (matrix.scenario == 'clisp_native') || (matrix.scenario == 'clisp_fallback') 87 | run: | 88 | sudo apt-get install clisp 89 | - if: matrix.scenario == 'clisp_native' 90 | run: | 91 | clisp /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests.lisp 92 | - if: matrix.scenario == 'clisp_fallback' 93 | run: | 94 | clisp /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests-fallback.lisp 95 | 96 | - if: (matrix.scenario == 'cmucl_native') || (matrix.scenario == 'cmucl_fallback') 97 | run: | 98 | sudo apt-get install cmucl 99 | - if: matrix.scenario == 'cmucl_native' 100 | run: | 101 | cmucl -load /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests.lisp 102 | - if: matrix.scenario == 'cmucl_fallback' 103 | run: | 104 | cmucl -load /home/runner/work/cl-custom-hash-table/cl-custom-hash-table/.github/workflows/github-workflow-tests-fallback.lisp 105 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | CL-CUSTOM-HASH-TABLE: Custom hash tables for Common Lisp 2 | ======================================================== 3 | 4 | [![](https://github.com/metawilm/cl-custom-hash-table/actions/workflows/run-tests.yaml/badge.svg?branch=master)](https://github.com/metawilm/cl-custom-hash-table/actions) 5 | 6 | Introduction 7 | ------------ 8 | 9 | CL-CUSTOM-HASH-TABLE allows creation and use of "custom hash tables". 10 | Custom hash tables can use arbitrary TEST/HASH functions, 11 | in addition to the TEST functions allowed by the standard 12 | (EQ, EQL, EQUAL and EQUALP). 13 | 14 | This library is primarily a compatibility layer, unifying how to create these hash table in different Lisp implementations. Furthermore this library provides a simple yet fully functional fall-back solution for implementations that don't support this functionality natively (yet). 15 | 16 | License 17 | ------- 18 | 19 | CL-CUSTOM-HASH-TABLE is released under a [BSD-like license](http://www.opensource.org/licenses/bsd-license.php), see the ASD file. 20 | 21 | Compatibility 22 | ------------- 23 | 24 | This library does not shadow symbols in the COMMON-LISP package. It does require that all access to (potential) custom hash tables is lexical wrapped in a WITH-CUSTOM-HASH-TABLE form (see example below). 25 | 26 | The standard hash table related functions are **supported**: 27 | 28 | * get/set: GETHASH, REMHASH, CLRHASH; 29 | * iteration: WITH-HASH-TABLE-ITERATOR, MAPHASH; 30 | * statistics: HASH-TABLE-P, HASH-TABLE-TEST, HASH-TABLE-COUNT, HASH-TABLE-REHASH-SIZE, HASH-TABLE-REHASH-THRESHOLD, HASH-TABLE-SIZE. 31 | 32 | Hash table iteration using LOOP (using HASH-KEY or HASH-VALUE) is **not supported** in Lisp implementations where the fall-back solution is used, therefore cannot be used in core that is supposed to be portable. 33 | 34 | In the fall-back solution HASH-TABLE-COUNT returns the correct number of entries, but HASH-TABLE-SIZE returns the size of the underlying helper hash table which might be lower than HASH-TABLE-COUNT. Functions HASH-TABLE-REHASH-SIZE and HASH-TABLE-REHASH-THRESHOLD also refer to that helper hash table. 35 | 36 | The fall-back solution is not thread-safe. The native implementation may or may not be. 37 | 38 | Supported implementations 39 | ------------------------- 40 | 41 | | Common Lisp Implementation | Native | Fallback | 42 | |:-:|:-:|:-:| 43 | | [ABCL](https://common-lisp.net/project/armedbear/) | ? | ? | 44 | | [Allegro CL](http://franz.com/products/allegrocl/) | ? | ? | 45 | | [Clozure CL](http://clozure.com/clozurecl.html) | ? | ? | 46 | | [CLISP 2.49.93](https://clisp.sourceforge.io) | ✅ | ✅ | 47 | | [CMUCL](http://www.cons.org/cmucl/) | ? | ? | 48 | | [ECL 23.9.9](https://ecl.common-lisp.dev) | ✅ | ✅ | 49 | | [LispWorks](http://www.lispworks.com/) | ? | ? | 50 | | [SBCL 2.1.11](https://www.sbcl.org) | ✅ | ✅ | 51 | 52 | Example 53 | ------- 54 | 55 | Custom TEST and HASH functions: 56 | 57 | (defun foo-equal-p (x y) (= x y)) 58 | (defun foo-hash (x) (mod x 10)) 59 | 60 | Define the hash table type: 61 | 62 | (use-package :cl-custom-hash-table) 63 | 64 | (define-custom-hash-table-constructor make-foo-ht 65 | :test foo-equal-p :hash-function foo-hash) 66 | 67 | Now MAKE-FOO-HT is a function that will create the custom hash table: 68 | 69 | (defparameter *foo-ht* (make-foo-ht) 70 | "Hash table using FOO-HASH and FOO-EQUAL-P") 71 | 72 | You can trace your test/hash functions to check they are really getting called later: 73 | 74 | (trace foo-equal-p foo-hash) 75 | 76 | Use WITH-CUSTOM-HASH-TABLE around access to the hash table. 77 | This ensures functions GETHASH, REMHASH and MAPHASH do the right thing. 78 | If you forget this, your code will not work in implementations 79 | that don't support custom TEST/HASH functions natively! 80 | 81 | (with-custom-hash-table 82 | (setf (gethash 1 *foo-ht*) 1 83 | (gethash 10 *foo-ht*) 10 84 | (gethash 2 *foo-ht*) 2) 85 | (maphash (lambda (k v) 86 | (format t "~A: ~A~%" k v) 87 | (remhash k *foo-ht*)) 88 | *foo-ht*)) 89 | 90 | Implementation details 91 | ---------------------- 92 | 93 | Several Lisp implementations already support 94 | custom TEST and HASH arguments for MAKE-HASH-TABLE. 95 | This library is a small wrapper around the vendor-specific extensions. 96 | (Allegro CL, CCL, CMUCL, ECL, LispWorks, SBCL) 97 | 98 | In other Lisp implementations (ABCL, CLISP) a fall-back solution is used: 99 | 100 | * custom hash tables are created on top of standard hash tables; 101 | * the WITH-CUSTOM-HASH-TABLE code walker replaces GETHASH and friends by custom functions that work on both standard and "custom" hash tables. 102 | 103 | How does this compare to [genhash](http://www.cliki.net/genhash)? 104 | ---------------------------------- 105 | 106 | * genhash is complete hash table implementation; CL-CUSTOM-HASH-TABLE is primarily a compatibility layer, and offers a simple fall-back solution built on top of standard hash tables. 107 | * genhash comes with its own API; CL-CUSTOM-HASH-TABLE uses the standard hash table API. -------------------------------------------------------------------------------- /cl-custom-hash-table-test.asd: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER -*- 2 | (in-package :cl-user) 3 | 4 | (asdf:defsystem #:cl-custom-hash-table-test 5 | :name "CL-CUSTOM-HASH-TABLE-TEST: Test for CL-CUSTOM-HASH-TABLE" 6 | :depends-on (:hu.dwim.stefil :cl-custom-hash-table) 7 | :components ((:file "test-package") 8 | (:file "test-suite" :depends-on ("test-package")))) -------------------------------------------------------------------------------- /cl-custom-hash-table.asd: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER -*- 2 | (in-package :cl-user) 3 | 4 | (asdf:defsystem #:cl-custom-hash-table 5 | :name "CL-CUSTOM-HASH-TABLE: Custom hash tables for Common Lisp" 6 | :long-description "This library allows creation of hash tables with arbitrary TEST/HASH functions, 7 | in addition to the TEST functions allowed by the standard (EQ, EQL, EQUAL and EQUALP), 8 | even in implementations that don't support this functionality directly." 9 | :author "Willem Broekema" 10 | :version "0.3" 11 | :licence " 12 | Copyright (c) 2010-2014, Willem Broekema 13 | All rights reserved. 14 | 15 | Redistribution and use in source and binary forms, with or without modification, are permitted 16 | provided that the following conditions are met: 17 | 18 | * Redistributions of source code must retain the above copyright notice, this list of 19 | conditions and the following disclaimer. 20 | 21 | * Redistributions in binary form must reproduce the above copyright notice, this list of 22 | conditions and the following disclaimer in the documentation and/or other materials 23 | provided with the distribution. 24 | 25 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS \"AS IS\" AND ANY EXPRESS 26 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY 27 | AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 28 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 29 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 30 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 31 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 32 | OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 | POSSIBILITY OF SUCH DAMAGE." 34 | :components ((:file "package") 35 | (:file "custom-hash-table" :depends-on ("package")))) 36 | -------------------------------------------------------------------------------- /custom-hash-table.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-CUSTOM-HASH-TABLE -*- 2 | 3 | (in-package #:cl-custom-hash-table) 4 | 5 | (defmacro checking-reader-conditionals (&whole whole &body body) 6 | "Break unless the body contains exactly one form. Inspired by code from Steve Haflich." 7 | (let ((num (length body))) 8 | (unless (= num 1) 9 | (break "A CHECKING-READER-CONDITIONALS expression returned ~r forms (instead of one): ~s" 10 | num whole)) 11 | (car body))) 12 | 13 | #+custom-hash-table-fallback 14 | (defstruct (custom-hash-table (:conc-name cht.)) 15 | test hash-function real-ht) 16 | 17 | (defmacro define-custom-hash-table-constructor (make &key test hash-function) 18 | "Generate a function that can be used to create a new hash table that uses the given TEST and HASH-FUNCTION. 19 | For example: (DEFINE-CUSTOM-HASH-TABLE-CONSTRUCTOR MAKE-FOO-HT :TEST FOO-EQUAL-P :HASH-FUNCTION FOO-HASH) 20 | defines function (MAKE-FOO-HT &REST OPTIONS). 21 | OPTIONS are passed on to MAKE-HASH-TABLE if the platform supports custom hash tables natively, and ignored otherwise." 22 | (check-type make symbol) 23 | (check-type test symbol) 24 | (check-type hash-function symbol) 25 | 26 | (checking-reader-conditionals 27 | 28 | #+custom-hash-table-fallback 29 | `(defun ,make (&rest options) 30 | (declare (ignore options)) 31 | (make-custom-hash-table :test ',test 32 | :hash-function ',hash-function 33 | :real-ht (make-hash-table :test 'eql))) 34 | 35 | #+(and custom-hash-table-native cmu) 36 | (let ((hash-table-test-sym (intern (format nil "custom-hash-table ~A ~A" test hash-function) #.*package*))) 37 | `(progn 38 | (extensions:define-hash-table-test ',hash-table-test-sym (function ,test) (function ,hash-function)) 39 | (defun ,make (&rest options) 40 | (apply #'make-hash-table :test ',hash-table-test-sym options)))) 41 | 42 | #+(and custom-hash-table-native (not cmu)) 43 | `(defun ,make (&rest options) 44 | (apply #'make-hash-table :test ',test :hash-function ',hash-function options)))) 45 | 46 | (defmacro with-custom-hash-table (&body body) 47 | "Wrap BODY in an environment where access to custom hash-tables (GET-HASH etc) works as expected. 48 | This macro is a no-op in Lisp implementations that support custom hash-tables natively, but it is 49 | required in implementations where the fallback solution is used (*FEATURES* value :CUSTOM-HASH-TABLE-FALLBACK)" 50 | #-custom-hash-table-fallback 51 | `(progn ,@body) 52 | #+custom-hash-table-fallback 53 | `(progn ,@(walk-code body))) 54 | 55 | #+custom-hash-table-fallback 56 | (progn 57 | 58 | (defun walk-code (body) 59 | "Replace hash operators by their custom variant" 60 | (flet ((contains-unsupported-loop () 61 | (subst-if 'unused (lambda (form) 62 | (if (and (listp form) 63 | (symbolp (car form)) 64 | (string= (car form) 'loop) 65 | (loop for x in (cdr form) 66 | thereis (and (symbolp x) 67 | (member x '(hash-key hash-keys 68 | hash-value hash-values) 69 | :test 'string=)))) 70 | (return-from contains-unsupported-loop form) 71 | nil)) 72 | body) 73 | nil)) 74 | (let ((loop-form (contains-unsupported-loop))) 75 | (when loop-form 76 | (error "Iterating with LOOP over a hash table is unsupported by CL-CUSTOM-HASH-TABLE. ~ 77 | Please use WITH-HASH-TABLE-ITERATOR or MAPHASH instead. 78 | Offending form: ~S" loop-form)))) 79 | 80 | ;; Don't destructively modify original source conses 81 | (setf body (copy-tree body)) 82 | (loop for custom-sym in '(hash-table-p hash-table-test make-hash-table gethash remhash hash-table-count 83 | maphash with-hash-table-iterator clrhash hash-table-rehash-size 84 | hash-table-rehash-threshold hash-table-size) 85 | for cl-sym = (find-symbol (symbol-name custom-sym) '#:common-lisp) 86 | do (setf body (nsubst custom-sym cl-sym body)) 87 | finally (return body))) 88 | 89 | (defun hash-table-p (ht) 90 | (typep ht '(or hash-table custom-hash-table))) 91 | 92 | (defun gethash (key ht &optional default) 93 | (etypecase ht 94 | (hash-table (cl:gethash key ht default)) 95 | (custom-hash-table (let* ((test-fn (cht.test ht)) 96 | (hash-fn (cht.hash-function ht)) 97 | (real-ht (cht.real-ht ht)) 98 | (key.hash (funcall hash-fn key)) 99 | (existing-values (gethash key.hash real-ht))) 100 | (loop for x-and-val in existing-values 101 | for (x-key . x-val) = x-and-val 102 | when (funcall test-fn key x-key) 103 | do (return-from gethash (values x-val t)) 104 | finally (return (values default nil))))))) 105 | 106 | (defun (setf gethash) (new-val key ht &optional default) 107 | (declare (ignore default)) 108 | (etypecase ht 109 | (hash-table (setf (cl:gethash key ht) new-val)) 110 | (custom-hash-table (let* ((test-fn (cht.test ht)) 111 | (hash-fn (cht.hash-function ht)) 112 | (real-ht (cht.real-ht ht)) 113 | (key.hash (funcall hash-fn key)) 114 | (existing-values (gethash key.hash real-ht))) 115 | (loop for x-and-val in existing-values 116 | for (x-key . nil) = x-and-val 117 | when (funcall test-fn key x-key) 118 | do (progn (setf (cdr x-and-val) new-val) 119 | (return-from gethash new-val)) 120 | finally (push (cons key new-val) (gethash key.hash real-ht)) 121 | (return new-val)))))) 122 | 123 | (defun remhash (key ht) 124 | (etypecase ht 125 | (hash-table (cl:remhash key ht)) 126 | (custom-hash-table (let* ((test-fn (cht.test ht)) 127 | (hash-fn (cht.hash-function ht)) 128 | (real-ht (cht.real-ht ht)) 129 | (key.hash (funcall hash-fn key)) 130 | (existing-values (gethash key.hash real-ht))) 131 | (loop for x-and-val in existing-values 132 | for (x-key . nil) = x-and-val 133 | when (funcall test-fn key x-key) 134 | do (let ((new-val (delete x-and-val existing-values))) 135 | (if new-val 136 | (setf (gethash key.hash real-ht) new-val) 137 | (remhash key.hash real-ht))) 138 | (return-from remhash t) 139 | finally (return nil)))))) 140 | 141 | (defun hash-table-count (ht) 142 | (etypecase ht 143 | (hash-table (cl:hash-table-count ht)) 144 | (custom-hash-table (loop with real-ht = (cht.real-ht ht) 145 | for entries being each hash-value in real-ht 146 | sum (length entries))))) 147 | 148 | (defun maphash (function ht) 149 | ;; When changing, ensure remhash and (setf gethash) on current key are supported. 150 | (etypecase ht 151 | (hash-table (cl:maphash function ht)) 152 | (custom-hash-table (loop with real-ht = (cht.real-ht ht) 153 | for entries being each hash-value in real-ht 154 | do (loop while entries 155 | do (destructuring-bind (k . v) 156 | (pop entries) 157 | (funcall function k v))))))) 158 | 159 | (defmacro with-gensyms (list &body body) 160 | `(let ,(loop for x in list 161 | collect `(,x (gensym ,(symbol-name x)))) 162 | ,@body)) 163 | 164 | (defmacro with-hash-table-iterator ((name hash-table) &body body) 165 | (with-gensyms (ht real-ht real-iter current-key-val-list k v entry-p real-key real-val) 166 | `(let ((,ht ,hash-table)) 167 | (etypecase ,ht 168 | (hash-table (cl:with-hash-table-iterator (,name ,ht) ,@body)) 169 | (custom-hash-table 170 | (let ((,real-ht (cht.real-ht ,ht))) 171 | (cl:with-hash-table-iterator (,real-iter ,real-ht) 172 | (let (,current-key-val-list) 173 | (macrolet 174 | ((,name () '(loop named ,name 175 | do (if ,current-key-val-list 176 | (destructuring-bind (,k . ,v) 177 | (pop ,current-key-val-list) 178 | (return-from ,name (values t ,k ,v))) 179 | (multiple-value-bind (,entry-p ,real-key ,real-val) 180 | (,real-iter) 181 | (declare (ignore ,real-key)) 182 | (if ,entry-p 183 | (setf ,current-key-val-list ,real-val) 184 | (return-from ,name nil))))))) 185 | ,@body))))))))) 186 | 187 | (progn 188 | (defun clrhash (ht) 189 | (cl:clrhash #1=(etypecase ht 190 | (hash-table ht) 191 | (custom-hash-table (cht.real-ht ht))))) 192 | 193 | (defun hash-table-rehash-size (ht) 194 | (cl:hash-table-rehash-size #1#)) 195 | 196 | (defun hash-table-rehash-threshold (ht) 197 | (cl:hash-table-rehash-threshold #1#)) 198 | 199 | (defun hash-table-size (ht) 200 | (cl:hash-table-size #1#)) 201 | 202 | (defun hash-table-test (ht) 203 | (etypecase ht 204 | (hash-table (cl:hash-table-test ht)) 205 | (custom-hash-table (cht.test ht))))) 206 | 207 | ) ;; #+ -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER -*- 2 | 3 | (in-package #:cl-user) 4 | 5 | (eval-when (:compile-toplevel :load-toplevel :execute) 6 | 7 | #-(or custom-hash-table-fallback custom-hash-table-native) 8 | (flet ((register-feature (feature present-p) 9 | (check-type feature keyword) 10 | (if present-p 11 | (pushnew feature *features*) 12 | (setf *features* (remove feature *features*))))) 13 | (let ((native (or #+(or allegro ccl cmu ecl lispworks sbcl) t))) 14 | (register-feature :custom-hash-table-native native) 15 | (register-feature :custom-hash-table-fallback (not native)))) 16 | 17 | #+(and custom-hash-table-fallback custom-hash-table-native) 18 | (error "Cannot have both :CUSTOM-HASH-TABLE-NATIVE and :CUSTOM-HASH-TABLE-NATIVE in *FEATURES*")) 19 | 20 | 21 | (defpackage #:cl-custom-hash-table 22 | (:use #:common-lisp) 23 | (:export #:define-custom-hash-table-constructor #:with-custom-hash-table) 24 | #+custom-hash-table-fallback 25 | (:export #:custom-hash-table) 26 | #+custom-hash-table-fallback 27 | (:shadow #:hash-table-p #:hash-table-test #:gethash #:remhash #:hash-table-count #:maphash 28 | #:with-hash-table-iterator #:clrhash #:hash-table-rehash-size 29 | #:hash-table-rehash-threshold #:hash-table-size)) 30 | -------------------------------------------------------------------------------- /test-package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER -*- 2 | 3 | (in-package :cl-user) 4 | 5 | (defpackage #:cl-custom-hash-table-test 6 | (:use #:cl-custom-hash-table #:hu.dwim.stefil #:common-lisp) 7 | #+custom-hash-table-fallback 8 | (:import-from #:cl-custom-hash-table #:custom-hash-table) 9 | (:export #:run #:run-without-debugging)) 10 | -------------------------------------------------------------------------------- /test-suite.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-CUSTOM-HASH-TABLE-TEST -*- 2 | 3 | (in-package :cl-custom-hash-table-test) 4 | 5 | (defsuite* test-suite) 6 | 7 | #+custom-hash-table-fallback 8 | (format t "Using FALLBACK custom hash table implementation.~%") 9 | #+custom-hash-table-native 10 | (format t "Using NATIVE custom hash table implementation.~%") 11 | 12 | (defvar *foo-equal-count*) 13 | 14 | (defun foo-equal-p (x y) 15 | (when (boundp '*foo-equal-count*) 16 | (incf *foo-equal-count*)) 17 | (= x y)) 18 | 19 | (defun foo-hash (x) 20 | (mod x 10)) 21 | 22 | (define-custom-hash-table-constructor make-foo-ht 23 | :test foo-equal-p :hash-function foo-hash) 24 | 25 | (deftest basic-test () 26 | 27 | (let ((foo-ht (make-foo-ht)) 28 | (normal-ht (make-hash-table :test 'eql))) 29 | 30 | (is (typep normal-ht 'hash-table)) 31 | 32 | #+custom-hash-table-fallback 33 | (progn (is (typep foo-ht 'custom-hash-table)) 34 | (is (not (typep normal-ht 'custom-hash-table)))) 35 | 36 | #+custom-hash-table-native 37 | (is (typep foo-ht 'hash-table)) 38 | 39 | (with-custom-hash-table 40 | #+custom-hash-table-native 41 | (is (member (hash-table-test foo-ht) (list 'foo-equal-p #'foo-equal-p))) 42 | #+custom-hash-table-fallback 43 | (is (eq (hash-table-test foo-ht) 'foo-equal-p)) 44 | 45 | #-clisp ;; Does not return 'eql : http://www.clisp.org/impnotes/ht-test.html 46 | (is (eq (hash-table-test normal-ht) 'eql))) 47 | 48 | (dolist (ht (list foo-ht normal-ht)) 49 | (let ((is-custom (eq ht foo-ht))) 50 | 51 | (with-custom-hash-table 52 | 53 | (is (hash-table-p ht)) 54 | 55 | (setf (gethash 1 ht) 1 56 | (gethash 10 ht) 10 57 | (gethash 20 ht) 20) 58 | ;; (1 . 1) (10 . 10) (20 . 20) 59 | (let ((*foo-equal-count* 0)) 60 | (is (= (gethash 1 ht) 1)) 61 | (when is-custom 62 | (is (plusp *foo-equal-count*)))) 63 | (let ((*foo-equal-count* 0)) 64 | (is (null (gethash 30 ht))) 65 | (when is-custom 66 | #+custom-hash-table-native 67 | (is (<= 2 *foo-equal-count*)) ;; tested 10, 20, possibly more 68 | #+custom-hash-table-fallback 69 | (is (= 2 *foo-equal-count*)))) ;; tested 10, 20 70 | (is (remhash 1 ht)) 71 | ;; (10 . 10) (20 . 20) 72 | (is (not (remhash 1 ht))) 73 | (is (= (hash-table-count ht) 2)) 74 | (setf (gethash 1 ht) 1) 75 | (let ((expected '((1 . 1) (10 . 10) (20 . 20)))) 76 | (flet ((expected-p (set) 77 | (and (null (set-difference set expected :test 'equal)) 78 | (null (set-difference expected set :test 'equal))))) 79 | ;; Check MAPHASH 80 | (let (items) 81 | (maphash (lambda (k v) (push (cons k v) items)) ht) 82 | (is (expected-p items))) 83 | ;; Check WITH-HASH-TABLE-ITERATOR 84 | (let (items) 85 | (with-hash-table-iterator (next ht) 86 | (loop named iter-test 87 | do (multiple-value-bind (entry-p key val) (next) 88 | (if entry-p 89 | (push (cons key val) items) 90 | (return-from iter-test))))) 91 | (is (expected-p items))))) 92 | 93 | (clrhash ht) 94 | (is (zerop (hash-table-count ht))) 95 | (is (plusp (hash-table-rehash-size ht))) 96 | (is (plusp (hash-table-rehash-threshold ht))) 97 | (is (not (minusp (hash-table-size ht)))) 98 | 99 | (dotimes (i 1000) 100 | (setf (gethash i ht) (* 2 i)) 101 | (is (= (hash-table-count ht) (1+ i)))) 102 | ;; HT: {1 -> 2; 2 -> 4; ...; 999 -> 1998} 103 | 104 | (loop for i from 400 to 600 105 | do (is (= (gethash i ht) (* 2 i))) 106 | (setf (gethash i ht) (* 3 i))) 107 | ;; HT: {1 -> 2; 399 -> 798; 400 -> 1200; ...; 600 -> 1800; 601 -> 1202; ...; 999 -> 1998} 108 | 109 | (is (= (hash-table-count ht) 1000)) 110 | (dotimes (i 1000) 111 | (is (= (gethash i ht) (if (<= 400 i 600) (* 3 i) (* 2 i))))) 112 | 113 | (dotimes (i 1000) 114 | (is (remhash i ht)) 115 | (is (not (remhash (+ i 1000) ht))) 116 | (is (= (hash-table-count ht) (- 999 i)))))))) 117 | 118 | (signals error (eval '(with-custom-hash-table 119 | (loop for x being the hash-key in (make-hash-table) 120 | do nil)))) 121 | (signals error (eval '(with-custom-hash-table 122 | (loop for x being the hash-keys in (make-hash-table) 123 | do nil)))) 124 | (signals error (eval '(with-custom-hash-table 125 | (loop for x being the :hash-value in (make-hash-table) 126 | do nil)))) 127 | (signals error (eval '(with-custom-hash-table 128 | (loop for x being the #:hash-values in (make-hash-table) 129 | do nil)))) 130 | t) 131 | 132 | (defun test-failures-p () 133 | (when (plusp #1=(length (hu.dwim.stefil::failure-descriptions-of *last-test-result*))) 134 | #1#)) 135 | 136 | (defun run-without-debugging () 137 | (without-debugging (run)) 138 | (if #1=(test-failures-p) 139 | (error "There were ~d test failures" #1#) 140 | (format t "No test failures.~%"))) 141 | 142 | (defun run () 143 | (prog1 (basic-test) 144 | (if #1=(test-failures-p) 145 | (format t "~%There were ~d test failures~%" #1#) 146 | (format t "~%Test success!~%")))) 147 | --------------------------------------------------------------------------------