From: Nikodemus Siivola Date: Thu, 21 May 2009 09:56:16 +0000 (+0000) Subject: 1.0.28.63: SB-EXT:DEFINE-HASH-TABLE-TEST X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=146ca8325e1d9e206a6c14e76442543267dbbc51;p=sbcl.git 1.0.28.63: SB-EXT:DEFINE-HASH-TABLE-TEST * Based on old SB-INT:DEFINE-HASH-TABLE-TEST, but: ** macro, not a function. ** only two arguments: name of the test function, and the hash function (which can also be a lambda form.) ** :TEST accepts both 'NAME, and #'NAME as well. ** pick up redefinitions of the test and hash-function without re-executing the D-H-T-T form. ** protected by package locks. * MAKE-HASH-TABLE :HASH-FUNCTION supported as well. EQ-based hashing not legal for user-provided hash functions, accidents prevented by wrapping functions which may return a true secondary value in a closure. * Documentation -- other hash-table extensions as well. * Documentation generation improvements: ** use the shortest package name available -- CL:FOO, not COMMON-LISP:FOO. ** kludge around texi2pdf making &key and company bold ** add exceptions so that we don't format words ANSI and CLHS as lowecase symbols. --- diff --git a/NEWS b/NEWS index 2c13f97..4b3e1a9 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,9 @@ allowed to return, which causes SBCL to quit with exit status 0. Previously if the function returned with a small integer return value, that value was accidentally reused as the exit status. + * new feature: SB-EXT:DEFINE-HASH-TABLE-TEST allows defining new arguments + to MAKE-HASH-TABLE :TEST, and MAKE-HASH-TABLE has been extended with + :HASH-FUNCTION argument. Refer to user manual for details. * new feature: SB-EXT:DEFGLOBAL macro allows defining global non-special variables. * new feature: SB-EXT:ALWAYS-BOUND proclamation inhibits MAKUNBOUND, and diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index a00ae6a..c492969 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -13,6 +13,7 @@ it still has quite a few. @xref{Contributed Modules}. * Customization Hooks for Users:: * Tools To Help Developers:: * Resolution of Name Conflicts:: +* Hash Table Extensions:: * Miscellaneous Extensions:: * Stale Extensions:: * Efficiency Hacks:: @@ -27,7 +28,8 @@ specified by ANSI. Weak pointers allow references to objects to be maintained without keeping them from being garbage collected, and ``finalization'' hooks are available to cause code to be executed when an object has been garbage collected. Additionally users can specify -their own cleanup actions to be executed with garbage collection. +their own cleanup actions to be executed with garbage collection. See +also @code{make-hash-table} for information on weak hash tables. @include fun-sb-ext-finalize.texinfo @include fun-sb-ext-cancel-finalization.texinfo @@ -376,6 +378,23 @@ the @code{sb-ext:resolve-conflict} restart should be invoked with one argument, which should be a member of the list returned by the condition accessor @code{sb-ext:name-conflict-symbols}. +@node Hash Table Extensions +@comment node-name, next, previous, up +@section Hash Table Extensions + +Hash table extensions supported by SBCL are all controlled by keyword +arguments to @code{make-hash-table}. + +@include fun-common-lisp-make-hash-table.texinfo + +@include macro-sb-ext-define-hash-table-test.texinfo + +@include macro-sb-ext-with-locked-hash-table.texinfo + +@include fun-sb-ext-hash-table-synchronized-p.texinfo + +@include fun-sb-ext-hash-table-weakness.texinfo + @node Miscellaneous Extensions @comment node-name, next, previous, up @section Miscellaneous Extensions diff --git a/doc/manual/docstrings.lisp b/doc/manual/docstrings.lisp index 86b1212..c258d20 100644 --- a/doc/manual/docstrings.lisp +++ b/doc/manual/docstrings.lisp @@ -83,7 +83,7 @@ you deserve to lose.") "Characters that might start an itemization in docstrings when at the start of a line.") -(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+&" +(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+&#'" "List of characters that make up symbols in a docstring.") (defparameter *symbol-delimiters* " ,.!?;") @@ -226,6 +226,10 @@ symbols or lists of symbols.")) (let ((kind (get-kind doc))) (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) +(defun short-package-name (package) + (car (sort (copy-list (cons (package-name package) (package-nicknames package))) + #'< :key #'length))) + ;;; Definition titles for DOCUMENTATION instances (defgeneric title-using-kind/name (kind name doc)) @@ -236,12 +240,12 @@ symbols or lists of symbols.")) (defmethod title-using-kind/name (kind (name symbol) doc) (declare (ignore kind)) - (format nil "~A:~A" (package-name (get-package doc)) name)) + (format nil "~A:~A" (short-package-name (get-package doc)) name)) (defmethod title-using-kind/name (kind (name list) doc) (declare (ignore kind)) (assert (setf-name-p name)) - (format nil "(setf ~A:~A)" (package-name (get-package doc)) (second name))) + (format nil "(setf ~A:~A)" (short-package-name (get-package doc)) (second name))) (defmethod title-using-kind/name ((kind (eql 'method)) name doc) (format nil "~{~A ~}~A" @@ -390,11 +394,22 @@ there is no corresponding docstring." (clean (cdr x) :key key :optional optional)))))) (clean (sb-introspect:function-lambda-list (get-name doc)))))))) +(defun get-string-name (x) + (let ((name (get-name x))) + (cond ((symbolp name) + (symbol-name name)) + ((and (consp name) (eq 'setf (car name))) + (symbol-name (second name))) + ((stringp name) + name) + (t + (error "Don't know which symbol to use for name ~S" name))))) + (defun documentation< (x y) (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) (p2 (position (get-kind y) *ordered-documentation-kinds*))) (if (or (not (and p1 p2)) (= p1 p2)) - (string< (string (get-name x)) (string (get-name y))) + (string< (get-string-name x) (get-string-name y)) (< p1 p2)))) ;;;; turning text into texinfo @@ -415,39 +430,44 @@ with #\@. Optionally downcase the result." ;;; line markups +(defvar *not-symbols* '("ANSI" "CLHS")) + (defun locate-symbols (line) "Return a list of index pairs of symbol-like parts of LINE." ;; This would be a good application for a regex ... - (do ((result nil) - (begin nil) - (maybe-begin t) - (i 0 (1+ i))) - ((= i (length line)) - ;; symbol at end of line - (when (and begin (or (> i (1+ begin)) - (not (member (char line begin) '(#\A #\I))))) - (push (list begin i) result)) - (nreverse result)) - (cond - ((and begin (find (char line i) *symbol-delimiters*)) - ;; symbol end; remember it if it's not "A" or "I" - (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) - (push (list begin i) result)) - (setf begin nil - maybe-begin t)) - ((and begin (not (find (char line i) *symbol-characters*))) - ;; Not a symbol: abort - (setf begin nil)) - ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) - ;; potential symbol begin at this position - (setf begin i - maybe-begin nil)) - ((find (char line i) *symbol-delimiters*) - ;; potential symbol begin after this position - (setf maybe-begin t)) - (t - ;; Not reading a symbol, not at potential start of symbol - (setf maybe-begin nil))))) + (let (result) + (flet ((grab (start end) + (unless (member (subseq line start end) '("ANSI" "CLHS")) + (push (list start end) result)))) + (do ((begin nil) + (maybe-begin t) + (i 0 (1+ i))) + ((= i (length line)) + ;; symbol at end of line + (when (and begin (or (> i (1+ begin)) + (not (member (char line begin) '(#\A #\I))))) + (grab begin i)) + (nreverse result)) + (cond + ((and begin (find (char line i) *symbol-delimiters*)) + ;; symbol end; remember it if it's not "A" or "I" + (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) + (grab begin i)) + (setf begin nil + maybe-begin t)) + ((and begin (not (find (char line i) *symbol-characters*))) + ;; Not a symbol: abort + (setf begin nil)) + ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) + ;; potential symbol begin at this position + (setf begin i + maybe-begin nil)) + ((find (char line i) *symbol-delimiters*) + ;; potential symbol begin after this position + (setf maybe-begin t)) + (t + ;; Not reading a symbol, not at potential start of symbol + (setf maybe-begin nil))))))) (defun texinfo-line (line) "Format symbols in LINE texinfo-style: either as code or as @@ -686,7 +706,14 @@ followed another tabulation label or a tabulation body." "deffn")) (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) (title-name doc) - (lambda-list doc)))) + ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo + ;; interactions,so we escape the ampersand -- amusingly for TeX. + ;; sbcl.texinfo defines macros that expand @&key and friends to &key. + (mapcar (lambda (name) + (if (member name lambda-list-keywords) + (format nil "@~A" name) + name)) + (lambda-list doc))))) (defun texinfo-index (doc) (let ((title (title-name doc))) diff --git a/doc/manual/package-locks-extended.texinfo b/doc/manual/package-locks-extended.texinfo index 4e34560..ed22edc 100644 --- a/doc/manual/package-locks-extended.texinfo +++ b/doc/manual/package-locks-extended.texinfo @@ -292,6 +292,9 @@ Defining it as a method combination type. @item Using it as the class-name argument to setf of find-class. +@item +Defining it as a hash table test using @code{sb-ext:define-hash-table-test}. + @end enumerate @node Package Lock Dictionary diff --git a/doc/manual/sbcl.texinfo b/doc/manual/sbcl.texinfo index 1bb042d..56d307c 100644 --- a/doc/manual/sbcl.texinfo +++ b/doc/manual/sbcl.texinfo @@ -46,6 +46,21 @@ provided with absolutely no warranty. See the @file{COPYING} and @ifnottex +@c We use @&key, etc to escape & from TeX in lambda lists -- +@c so we need to define them for info as well. +@macro &optional +&optional +@end macro +@macro &rest +&rest +@end macro +@macro &key +&key +@end macro +@macro &body +&body +@end macro + @node Top @comment node-name, next, previous, up @top sbcl diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f078e71..138f893 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -696,11 +696,15 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; weak pointers and finalization "CANCEL-FINALIZATION" "FINALIZE" - "HASH-TABLE-WEAKNESS" "MAKE-WEAK-POINTER" - "WEAK-POINTER" "WEAK-POINTER-P" "WEAK-POINTER-VALUE" + "MAKE-WEAK-POINTER" + "WEAK-POINTER" + "WEAK-POINTER-P" + "WEAK-POINTER-VALUE" - ;; Hash table locking + ;; Hash table extensions + "DEFINE-HASH-TABLE-TEST" "HASH-TABLE-SYNCHRONIZED-P" + "HASH-TABLE-WEAKNESS" "WITH-LOCKED-HASH-TABLE" ;; If the user knows we're doing IEEE, he might reasonably @@ -1122,7 +1126,6 @@ possibly temporariliy, because it might be used internally." "GET-FLOATING-POINT-MODES" "SET-FLOATING-POINT-MODES" "WITH-FLOAT-TRAPS-MASKED" - "DEFINE-HASH-TABLE-TEST" ;; compatibility hacks for old-style CMU CL data formats "UNIX-ENVIRONMENT-CMUCL-FROM-SBCL" diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index f4bd831..710b24c 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -235,6 +235,23 @@ "Set NAME's global function definition." (declare (type function new-value) (optimize (safety 1))) (with-single-package-locked-error (:symbol name "setting fdefinition of ~A") + + ;; Check for hash-table stuff. Woe onto him that mixes encapsulation + ;; with this. + (when (and (symbolp name) (fboundp name) + (boundp '*user-hash-table-tests*)) + (let ((old (symbol-function name))) + (declare (special *user-hash-table-tests*)) + (dolist (spec *user-hash-table-tests*) + (cond ((eq old (second spec)) + ;; test-function + (setf (second spec) new-value)) + ((eq old (third spec)) + ;; hash-function + (setf (third spec) new-value)))))) + + ;; FIXME: This is a good hook to have, but we should probably + ;; reserve it for users. (let ((fdefn (fdefinition-object name t))) ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running ;; top level forms in the kernel core startup. diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 090606a..a9bcc87 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -126,62 +126,157 @@ ;;;; user-defined hash table tests -(defvar *hash-table-tests* nil) +(defvar *user-hash-table-tests* nil) -(defun define-hash-table-test (name test-fun hash-fun) - #!+sb-doc - "Define a new kind of hash table test." - (declare (type symbol name) - (type function test-fun hash-fun)) - (setf *hash-table-tests* - (cons (list name test-fun hash-fun) - (remove name *hash-table-tests* :test #'eq :key #'car))) +(defun register-hash-table-test (name hash-fun) + (declare (symbol name) (function hash-fun)) + (unless (fboundp name) + (error "Cannot register ~S has a hash table test: undefined function." + name)) + (with-single-package-locked-error + (:symbol name "defining ~S as a hash table test") + (let* ((test-fun (fdefinition name)) + (this (list name test-fun hash-fun)) + (spec (assoc name *user-hash-table-tests*))) + (cond (spec + (unless (and (eq (second spec) test-fun) + (eq (third spec) hash-fun)) + (style-warn "Redefining hash table test ~S." name) + (setf (cdr spec) (cdr this)))) + (t + (push this *user-hash-table-tests*))))) name) + +(defmacro define-hash-table-test (name hash-function) + #!+sb-doc + "Defines NAME as a new kind of hash table test for use with the :TEST +argument to MAKE-HASH-TABLE, and associates a default HASH-FUNCTION with it. + +NAME must be a symbol naming a global two argument equivalence predicate. +Afterwards both 'NAME and #'NAME can be used with :TEST argument. In both +cases HASH-TABLE-TEST will return the symbol NAME. + +HASH-FUNCTION must be a symbol naming a global hash function consistent with +the predicate, or be a LAMBDA form implementing one in the current lexical +environment. The hash function must compute the same hash code for any two +objects for which NAME returns true, and subsequent calls with already hashed +objects must always return the same hash code. + +Note: The :HASH-FUNCTION keyword argument to MAKE-HASH-TABLE can be used to +override the specified default hash-function. + +Attempting to define NAME in a locked package as hash-table test causes a +package lock violation. + +Examples: + + ;;; 1. + + ;; We want to use objects of type FOO as keys (by their + ;; names.) EQUALP would work, but would make the names + ;; case-insensitive -- wich we don't want. + (defstruct foo (name nil :type (or null string))) + + ;; Define an equivalence test function and a hash function. + (defun foo-name= (f1 f2) (equal (foo-name f1) (foo-name f2))) + (defun sxhash-foo-name (f) (sxhash (foo-name f))) + + (define-hash-table-test foo-name= sxhash-foo-name) + + ;; #'foo-name would work too. + (defun make-foo-table () (make-hash-table :test 'foo-name=)) + + ;;; 2. + + (defun == (x y) (= x y)) + + (define-hash-table-test == + (lambda (x) + ;; Hash codes must be consistent with test, so + ;; not (SXHASH X), since + ;; (= 1 1.0) => T + ;; (= (SXHASH 1) (SXHASH 1.0)) => NIL + ;; Note: this doesn't deal with complex numbers or + ;; bignums too large to represent as double floats. + (sxhash (coerce x 'double-float)))) + + ;; #'== would work too + (defun make-number-table () (make-hash-table :test '==)) +" + (check-type name symbol) + (if (member name '(eq eql equal equalp)) + (error "Cannot redefine standard hash table test ~S." name) + (cond ((symbolp hash-function) + `(register-hash-table-test ',name (symbol-function ',hash-function))) + ((and (consp hash-function) (eq 'lambda (car hash-function))) + `(register-hash-table-test ',name #',hash-function)) + (t + (error "Malformed HASH-FUNCTION: ~S" hash-function))))) ;;;; construction and simple accessors (defconstant +min-hash-table-size+ 16) (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0)) -(defun make-hash-table (&key (test 'eql) +(defun make-hash-table (&key + (test 'eql) (size +min-hash-table-size+) (rehash-size 1.5) (rehash-threshold 1) + (hash-function nil) (weakness nil) (synchronized)) #!+sb-doc "Create and return a new hash table. The keywords are as follows: - :TEST -- Indicates what kind of test to use. - :SIZE -- A hint as to how many elements will be put in this hash - table. - :REHASH-SIZE -- Indicates how to expand the table when it fills up. - If an integer, add space for that many elements. If a floating - point number (which must be greater than 1.0), multiply the size - by that amount. - :REHASH-THRESHOLD -- Indicates how dense the table can become before - forcing a rehash. Can be any positive number <=1, with density - approaching zero as the threshold approaches 0. Density 1 means an - average of one entry per bucket. - :WEAKNESS -- If NIL (the default) it is a normal non-weak hash table. - If one of :KEY, :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE it is a weak - hash table. - Depending on the type of weakness the lack of references to the - key and the value may allow for removal of the entry. If WEAKNESS - is :KEY and the key would otherwise be garbage the entry is eligible - for removal from the hash table. Similarly, if WEAKNESS is :VALUE - the life of an entry depends on its value's references. If WEAKNESS - is :KEY-AND-VALUE and either the key or the value would otherwise be - garbage the entry can be removed. If WEAKNESS is :KEY-OR-VALUE and - both the key and the value would otherwise be garbage the entry can - be removed. - :SYNCHRONIZED -- If NIL (the default), the hash-table may have - multiple concurrent readers, but results are undefined if a - thread writes to the hash-table concurrently with another - reader or writer. If T, all concurrent accesses are safe, but - note that CLHS 3.6 (Traversal Rules and Side Effects) remains - in force. See also: SB-EXT:WITH-LOCKED-HASH-TABLE. This keyword - argument is experimental, and may change incompatibly or be - removed in the future." + + :TEST + Determines how keys are compared. Must a designator for one of the + standard hash table tests, or a hash table test defined using + SB-EXT:DEFINE-HASH-TABLE-TEST. Additionally, when an explicit + HASH-FUNCTION is provided (see below), any two argument equivalence + predicate can be used as the TEST. + + :SIZE + A hint as to how many elements will be put in this hash table. + + :REHASH-SIZE + Indicates how to expand the table when it fills up. If an integer, add + space for that many elements. If a floating point number (which must be + greater than 1.0), multiply the size by that amount. + + :REHASH-THRESHOLD + Indicates how dense the table can become before forcing a rehash. Can be + any positive number <=1, with density approaching zero as the threshold + approaches 0. Density 1 means an average of one entry per bucket. + + :HASH-FUNCTION + If NIL (the default), a hash function based on the TEST argument is used, + which then must be one of the standardized hash table test functions, or + one for which a default hash function has been defined using + SB-EXT:DEFINE-HASH-TABLE-TEST. If HASH-FUNCTION is specified, the TEST + argument can be any two argument predicate consistent with it. The + HASH-FUNCTION is expected to return a non-negative fixnum hash code. + + :WEAKNESS + If NIL (the default) it is a normal non-weak hash table. If one + of :KEY, :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE it is a weak hash table. + Depending on the type of weakness the lack of references to the key and + the value may allow for removal of the entry. If WEAKNESS is :KEY and the + key would otherwise be garbage the entry is eligible for removal from the + hash table. Similarly, if WEAKNESS is :VALUE the life of an entry depends + on its value's references. If WEAKNESS is :KEY-AND-VALUE and either the + key or the value would otherwise be garbage the entry can be removed. If + WEAKNESS is :KEY-OR-VALUE and both the key and the value would otherwise + be garbage the entry can be removed. + + :SYNCHRONIZED + If NIL (the default), the hash-table may have multiple concurrent readers, + but results are undefined if a thread writes to the hash-table + concurrently with another reader or writer. If T, all concurrent accesses + are safe, but note that CLHS 3.6 (Traversal Rules and Side Effects) + remains in force. See also: SB-EXT:WITH-LOCKED-HASH-TABLE. This keyword + argument is experimental, and may change incompatibly or be removed in the + future." (declare (type (or function symbol) test)) (declare (type unsigned-byte size)) (multiple-value-bind (test test-fun hash-fun) @@ -194,15 +289,42 @@ ((or (eq test #'equalp) (eq test 'equalp)) (values 'equalp #'equalp #'equalp-hash)) (t - ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff. - ;; Failing that, I'd like to rename it to - ;; *USER-HASH-TABLE-TESTS*. - (dolist (info *hash-table-tests* - (error "unknown :TEST for MAKE-HASH-TABLE: ~S" - test)) + ;; FIXME: It would be nice to have a compiler-macro + ;; that resolved this at compile time: we could grab + ;; the alist cell in a LOAD-TIME-VALUE, etc. + (dolist (info *user-hash-table-tests* + (if hash-function + (if (functionp test) + (values (%fun-name test) test nil) + (values test (%coerce-callable-to-fun test) nil)) + (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" + test))) (destructuring-bind (test-name test-fun hash-fun) info (when (or (eq test test-name) (eq test test-fun)) (return (values test-name test-fun hash-fun))))))) + (when hash-function + (setf hash-fun + ;; Quickly check if the function has return return type which + ;; guarantees that the secondary return value is always NIL: + ;; (VALUES * &OPTIONAL), (VALUES * NULL ...) or (VALUES * + ;; &OPTIONAL NULL ...) + (let* ((actual (%coerce-callable-to-fun hash-function)) + (type-spec (%fun-type actual)) + (return-spec (when (consp type-spec) + (caddr type-spec))) + (extra-vals (when (consp return-spec) + (cddr return-spec)))) + (if (and (consp extra-vals) + (or (eq 'null (car extra-vals)) + (and (eq '&optional (car extra-vals)) + (or (not (cdr extra-vals)) + (eq 'null (cadr extra-vals)))))) + actual + ;; If there is a potential secondary value, make sure we + ;; don't accidentally claim EQ based hashing... + (lambda (object) + (declare (optimize (safety 0) (speed 3))) + (values (funcall actual object) nil)))))) (let* ((size (max +min-hash-table-size+ (min size ;; SIZE is just a hint, so if the user asks @@ -287,6 +409,10 @@ (setf (fdocumentation 'hash-table-rehash-threshold 'function) "Return the rehash-threshold HASH-TABLE was created with.") +#!+sb-doc +(setf (fdocumentation 'hash-table-synchronized-p 'function) + "Returns T if HASH-TABLE is synchronized.") + (defun hash-table-size (hash-table) #!+sb-doc "Return a size that can be used with MAKE-HASH-TABLE to create a hash diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 23a916c..0b553f5 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -790,6 +790,7 @@ (&key (:test callable) (:size unsigned-byte) (:rehash-size (or (integer 1) (float (1.0)))) (:rehash-threshold (real 0 1)) + (:hash-function (or null callable)) (:weakness (member nil :key :value :key-and-value :key-or-value)) (:synchronized t)) hash-table diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index c5c9786..119c9f1 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -391,4 +391,65 @@ ) +;;; DEFINE-HASH-TABLE-TEST + +(defstruct custom-hash-key name) +(defun custom-hash-test (x y) + (equal (custom-hash-key-name x) + (custom-hash-key-name y))) +(defun custom-hash-hash (x) + (sxhash (custom-hash-key-name x))) +(define-hash-table-test custom-hash-test custom-hash-hash) +(with-test (:name define-hash-table-test.1) + (let ((table (make-hash-table :test 'custom-hash-test))) + (setf (gethash (make-custom-hash-key :name "foo") table) :foo) + (setf (gethash (make-custom-hash-key :name "bar") table) :bar) + (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table))) + (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table))) + (assert (eq 'custom-hash-test (hash-table-test table)))) + (let ((table (make-hash-table :test #'custom-hash-test))) + (setf (gethash (make-custom-hash-key :name "foo") table) :foo) + (setf (gethash (make-custom-hash-key :name "bar") table) :bar) + (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table))) + (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table))) + (assert (eq 'custom-hash-test (hash-table-test table))))) + + +(defun head-eql (x y) + (every #'eql (subseq x 0 3) (subseq y 0 3))) +(define-hash-table-test head-eql + (lambda (x) + (logand most-positive-fixnum + (reduce #'+ (map 'list #'sxhash (subseq x 0 3)))))) +(with-test (:name define-hash-table-test.2) + (let ((table (make-hash-table :test 'head-eql))) + (setf (gethash #(1 2 3 4) table) :|123|) + (setf (gethash '(2 3 4 7) table) :|234|) + (setf (gethash "foobar" table) :foo) + (assert (eq :|123| (gethash '(1 2 3 ! 6) table))) + (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table))) + (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table))) + (assert (eq 'head-eql (hash-table-test table)))) + (let ((table (make-hash-table :test #'head-eql))) + (setf (gethash #(1 2 3 4) table) :|123|) + (setf (gethash '(2 3 4 7) table) :|234|) + (setf (gethash "foobar" table) :foo) + (assert (eq :|123| (gethash '(1 2 3 ! 6) table))) + (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table))) + (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table))) + (assert (eq 'head-eql (hash-table-test table))))) + +(with-test (:name make-hash-table/hash-fun) + (let ((table (make-hash-table + :test #'= + :hash-function (lambda (x) + (sxhash (coerce (abs x) 'double-float)))))) + (incf (gethash 1 table 0)) + (incf (gethash 1.0f0 table)) + (incf (gethash 1.0d0 table)) + (incf (gethash (complex 1.0f0 0.0f0) table)) + (incf (gethash (complex 1.0d0 0.0d0) table)) + (assert (= 5 (gethash 1 table))) + (assert (eq '= (hash-table-test table))))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index da2bf91..991ccde 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.28.62" +"1.0.28.63"