Permalink
Browse files

Use real structs instead of struct-like lists

  • Loading branch information...
1 parent 9c4d42c commit 6e4b10a34270b10235c3e731cc78c3a3f7d12717 @metawilm committed Feb 8, 2011
Showing with 43 additions and 49 deletions.
  1. +37 −45 custom-hash-table.lisp
  2. +3 −1 package.lisp
  3. +3 −3 test.lisp
@@ -10,6 +10,10 @@
num whole))
(car body)))
+#+custom-hash-table-fallback
+(defstruct (custom-hash-table (:conc-name cht.))
+ test hash-function real-ht)
+
(defmacro define-custom-hash-table-constructor (make &key test hash-function)
(check-type make symbol)
(check-type test symbol)
@@ -28,10 +32,9 @@
#+sbcl
(apply #'make-hash-table :test ',test :hash-function ',hash-function options)
#+ecl
- (list :custom-hash-table
- ',test
- ',hash-function
- (make-hash-table :test 'eql)))))))
+ (make-custom-hash-table :test ',test
+ :hash-function ',hash-function
+ :real-ht (make-hash-table :test 'eql)))))))
(defmacro with-custom-hash-table (&body body)
#-custom-hash-table-fallback
@@ -66,26 +69,22 @@ Offending form: ~S" loop-form))))
;; Don't destructively modify original source conses
(setf body (copy-tree body))
- (loop for custom-sym in '(gethash remhash hash-table-count maphash
- with-hash-table-iterator clrhash hash-table-rehash-size
+ (loop for custom-sym in '(hash-table-p make-hash-table gethash remhash hash-table-count
+ maphash with-hash-table-iterator clrhash hash-table-rehash-size
hash-table-rehash-threshold hash-table-size)
for cl-sym = (find-symbol (symbol-name custom-sym) '#:common-lisp)
do (setf body (nsubst custom-sym cl-sym body))
finally (return body)))
-(deftype custom-hash-table ()
- '(satisfies custom-hash-table-fallback-p))
-
-(defun custom-hash-table-fallback-p (x)
- (and (consp x) (eq (car x) :custom-hash-table)))
+(defun hash-table-p (ht)
+ (typep ht '(or hash-table custom-hash-table)))
(defun gethash (key ht &optional default)
(etypecase ht
(hash-table (cl:gethash key ht default))
- (custom-hash-table (pop ht)
- (let* ((test-fn (pop ht))
- (hash-fn (pop ht))
- (real-ht (pop ht))
+ (custom-hash-table (let* ((test-fn (cht.test ht))
+ (hash-fn (cht.hash-function ht))
+ (real-ht (cht.real-ht ht))
(key.hash (funcall hash-fn key))
(existing-values (gethash key.hash real-ht)))
(loop for x-and-val in existing-values
@@ -98,10 +97,9 @@ Offending form: ~S" loop-form))))
(declare (ignore default))
(etypecase ht
(hash-table (setf (cl:gethash key ht) new-val))
- (custom-hash-table (pop ht)
- (let* ((test-fn (pop ht))
- (hash-fn (pop ht))
- (real-ht (pop ht))
+ (custom-hash-table (let* ((test-fn (cht.test ht))
+ (hash-fn (cht.hash-function ht))
+ (real-ht (cht.real-ht ht))
(key.hash (funcall hash-fn key))
(existing-values (gethash key.hash real-ht)))
(loop for x-and-val in existing-values
@@ -113,10 +111,9 @@ Offending form: ~S" loop-form))))
(defun remhash (key ht)
(etypecase ht
(hash-table (cl:remhash key ht))
- (custom-hash-table (pop ht)
- (let* ((test-fn (pop ht))
- (hash-fn (pop ht))
- (real-ht (pop ht))
+ (custom-hash-table (let* ((test-fn (cht.test ht))
+ (hash-fn (cht.hash-function ht))
+ (real-ht (cht.real-ht ht))
(key.hash (funcall hash-fn key))
(existing-values (gethash key.hash real-ht)))
(loop for x-and-val in existing-values
@@ -132,15 +129,15 @@ Offending form: ~S" loop-form))))
(defun hash-table-count (ht)
(etypecase ht
(hash-table (cl:hash-table-count ht))
- (custom-hash-table (loop with real-ht = (fourth ht)
+ (custom-hash-table (loop with real-ht = (cht.real-ht ht)
for entries being each hash-value in real-ht
sum (length entries)))))
(defun maphash (function ht)
;; When changing, ensure remhash and (setf gethash) on current key are supported.
(etypecase ht
(hash-table (cl:maphash function ht))
- (custom-hash-table (loop with real-ht = (fourth ht)
+ (custom-hash-table (loop with real-ht = (cht.real-ht ht)
for entries being each hash-value in real-ht
do (loop while entries
do (destructuring-bind (k . v)
@@ -158,7 +155,7 @@ Offending form: ~S" loop-form))))
(etypecase ,ht
(hash-table (cl:with-hash-table-iterator (,name ,ht) ,@body))
(custom-hash-table
- (let ((,real-ht (fourth ,ht)))
+ (let ((,real-ht (cht.real-ht ,ht)))
(cl:with-hash-table-iterator (,real-iter ,real-ht)
(let (,current-key-val-list)
(macrolet
@@ -175,24 +172,19 @@ Offending form: ~S" loop-form))))
(return-from ,name nil)))))))
,@body)))))))))
-(defun clrhash (ht)
- (etypecase ht
- (hash-table (cl:clrhash ht))
- (custom-hash-table (cl:clrhash (fourth ht)))))
-
-(defun hash-table-rehash-size (ht)
- (etypecase ht
- (hash-table (cl:hash-table-rehash-size ht))
- (custom-hash-table (cl:hash-table-rehash-size (fourth ht)))))
-
-(defun hash-table-rehash-threshold (ht)
- (etypecase ht
- (hash-table (cl:hash-table-rehash-threshold ht))
- (custom-hash-table (cl:hash-table-rehash-threshold (fourth ht)))))
-
-(defun hash-table-size (ht)
- (etypecase ht
- (hash-table (cl:hash-table-size ht))
- (custom-hash-table (cl:hash-table-size (fourth ht)))))
+(progn
+ (defun clrhash (ht)
+ (cl:clrhash #1=(etypecase ht
+ (hash-table ht)
+ (custom-hash-table (cht.real-ht ht)))))
+
+ (defun hash-table-rehash-size (ht)
+ (cl:hash-table-rehash-size #1#))
+
+ (defun hash-table-rehash-threshold (ht)
+ (cl:hash-table-rehash-threshold #1#))
+
+ (defun hash-table-size (ht)
+ (cl:hash-table-size #1#)))
) ;; #+
View
@@ -15,6 +15,8 @@
(:use #:common-lisp)
(:export #:define-custom-hash-table-constructor #:with-custom-hash-table)
#+custom-hash-table-fallback
- (:shadow #:gethash #:remhash #:hash-table-count #:maphash
+ (:export #:custom-hash-table)
+ #+custom-hash-table-fallback
+ (:shadow #:hash-table-p #:gethash #:remhash #:hash-table-count #:maphash
#:with-hash-table-iterator #:clrhash #:hash-table-rehash-size
#:hash-table-rehash-threshold #:hash-table-size))
View
@@ -5,7 +5,7 @@
(defpackage #:cl-custom-hash-table.test
(:use #:cl-custom-hash-table #:common-lisp)
#+custom-hash-table-fallback
- (:import-from #:cl-custom-hash-table #:custom-hash-table-fallback-p)
+ (:import-from #:cl-custom-hash-table #:custom-hash-table)
(:export #:run))
(in-package :cl-custom-hash-table.test)
@@ -29,8 +29,8 @@
(defun run ()
(setf *foo-ht* (make-foo-ht))
#+custom-hash-table-fallback
- (progn (assert (custom-hash-table-fallback-p *foo-ht*))
- (assert (not (custom-hash-table-fallback-p (make-hash-table)))))
+ (progn (assert (typep *foo-ht* 'custom-hash-table))
+ (assert (not (typep (make-hash-table) 'custom-hash-table))))
(with-custom-hash-table
(setf (gethash 1 *foo-ht*) 1
(gethash 10 *foo-ht*) 10

0 comments on commit 6e4b10a

Please sign in to comment.