X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-hash-table.lisp;h=701f8a04ff75e1c409f7d441f1338b24faf9d2ff;hb=4cacd5df6c36c1815db4f09767017f5b85757ed1;hp=dea5d2c50ed66fa91924deafc0a21faeb5df90e8;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index dea5d2c..701f8a0 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -14,11 +14,17 @@ ;;;; utilities -(defconstant max-hash most-positive-fixnum) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant max-hash most-positive-fixnum)) (deftype hash () `(integer 0 ,max-hash)) +;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then +;;; explain why. If not (or if the reason it always makes a +;;; nonnegative FIXNUM is only the accident that pointers in supported +;;; architectures happen to be in the lower half of the address +;;; space), then fix it. #!-sb-fluid (declaim (inline pointer-hash)) (defun pointer-hash (key) (declare (values hash)) @@ -423,7 +429,7 @@ (defun %puthash (key hash-table value) (declare (type hash-table hash-table)) - (assert (hash-table-index-vector hash-table)) + (aver (hash-table-index-vector hash-table)) (without-gcing ;; We need to rehash here so that a current key can be found if it ;; exists. Check that there is room for one more entry. May not be @@ -477,7 +483,7 @@ ;; Pop a KV slot off the free list (let ((free-kv-slot (hash-table-next-free-kv hash-table))) ;; Double-check for overflow. - (assert (not (zerop free-kv-slot))) + (aver (not (zerop free-kv-slot))) (setf (hash-table-next-free-kv hash-table) (aref next-vector free-kv-slot)) (incf (hash-table-number-entries hash-table)) @@ -489,7 +495,7 @@ (when hash-vector (if (not eq-based) (setf (aref hash-vector free-kv-slot) hashing) - (assert (= (aref hash-vector free-kv-slot) #x80000000)))) + (aver (= (aref hash-vector free-kv-slot) #x80000000)))) ;; Push this slot into the next chain. (setf (aref next-vector free-kv-slot) next) @@ -498,8 +504,8 @@ (defun remhash (key hash-table) #!+sb-doc - "Remove the entry in HASH-TABLE associated with KEY. Returns T if there - was such an entry, and NIL if not." + "Remove the entry in HASH-TABLE associated with KEY. Return T if there + was such an entry, or NIL if not." (declare (type hash-table hash-table) (values (member t nil))) (without-gcing @@ -611,7 +617,7 @@ (do ((i 2 (1+ i))) ((>= i kv-length)) (setf (aref kv-vector i) +empty-ht-slot+)) - (assert (eq (aref kv-vector 0) hash-table)) + (aver (eq (aref kv-vector 0) hash-table)) ;; Set up the free list, all free. (do ((i 1 (1+ i))) ((>= i (1- size))) @@ -642,8 +648,8 @@ (declaim (inline maphash)) (defun maphash (function-designator hash-table) #!+sb-doc - "For each entry in HASH-TABLE, call the designated function on the key - and value of the entry. Return NIL." + "For each entry in HASH-TABLE, call the designated two-argument function + on the key and value of the entry. Return NIL." (let ((fun (%coerce-callable-to-function function-designator)) (size (length (hash-table-next-vector hash-table)))) (declare (type function fun)) @@ -659,33 +665,56 @@ ;;;; methods on HASH-TABLE -(def!method print-object ((ht hash-table) stream) +;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE +;;; when reconstructing HASH-TABLE. +(defun %hash-table-ctor-args (hash-table) + (when (hash-table-weak-p hash-table) + ;; FIXME: This might actually work with no trouble, but as of + ;; sbcl-0.6.12.10 when this code was written, weak hash tables + ;; weren't working yet, so I couldn't test it. When weak hash + ;; tables are supported again, this should be fixed. + (error "can't dump weak hash tables readably")) ; defensive programming.. + `(:test ',(hash-table-test hash-table) + :size ',(hash-table-size hash-table) + :rehash-size ',(hash-table-rehash-size hash-table) + :rehash-threshold ',(hash-table-rehash-threshold hash-table))) + +;;; Return an association list representing the same data as HASH-TABLE. +(defun %hash-table-alist (hash-table) + (let ((result nil)) + (maphash (lambda (key value) + (push (cons key value) result)) + hash-table) + result)) + +;;; Stuff an association list into HASH-TABLE. Return the hash table, +;;; so that we can use this for the *PRINT-READABLY* case in +;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET +;;; forms and readable gensyms and stuff. +(defun %stuff-hash-table (hash-table alist) + (dolist (x alist) + (setf (gethash (car x) hash-table) (cdr x))) + hash-table) + +(def!method print-object ((hash-table hash-table) stream) (declare (type stream stream)) - (print-unreadable-object (ht stream :type t :identity t) - (format stream - ":TEST ~S :COUNT ~D" - (hash-table-test ht) - (hash-table-number-entries ht)))) + (cond ((not *print-readably*) + (print-unreadable-object (hash-table stream :type t :identity t) + (format stream + ":TEST ~S :COUNT ~S" + (hash-table-test hash-table) + (hash-table-count hash-table)))) + ((not *read-eval*) + (error "can't print hash tables readably without *READ-EVAL*")) + (t + (with-standard-io-syntax + (format stream + "#.~W" + `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args + hash-table)) + ',(%hash-table-alist hash-table))))))) (def!method make-load-form ((hash-table hash-table) &optional environment) - (declare (ignorable environment)) - (values - `(make-hash-table - :test ',(hash-table-test hash-table) - :size ',(hash-table-size hash-table) - :rehash-size ',(hash-table-rehash-size hash-table) - :rehash-threshold ',(hash-table-rehash-threshold hash-table)) - (let ((alist nil)) - (maphash (lambda (key value) - (push (cons key value) alist)) - hash-table) - (if alist - ;; FIXME: It'd probably be more efficient here to write the - ;; hash table values as a SIMPLE-VECTOR rather than an alist. - ;; (Someone dumping a huge hash table might well thank us..) - `(stuff-hash-table ,hash-table ',alist) - nil)))) - -(defun stuff-hash-table (table alist) - (dolist (x alist) - (setf (gethash (car x) table) (cdr x)))) + (declare (ignore environment)) + (values `(make-hash-table ,@(%hash-table-ctor-args hash-table)) + `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))