2 ;;; hash-table.cl -- various lisp utilities for hash-tables
4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
9 ;;; Miscellaneous hash-table utilities
11 (defun make-hash-table-from-plist (plist &key
(test #'eql
))
12 (let ((h (make-hash-table :test test
)))
13 (loop for
(x y
) on plist by
#'cddr
14 do
(setf (gethash x h
) y
))
17 (defun make-hash-table-from-alist (alist &key
(test #'eql
))
18 (let ((h (make-hash-table :test test
)))
19 (loop for
(x . y
) in alist
20 do
(setf (gethash x h
) y
))
23 (defun hash-table-to-plist (h &aux l
)
27 (setf l
(cons (hash-table-to-plist val
)
32 (defun hash-ref (h &rest keys
)
33 (reduce #'(lambda (h k
) (gethash k h
)) keys
:initial-value h
))
35 (defun %put-hash-ref
(new-value h key
&rest more-keys
)
36 ;; not quite Perl-style autovivification, but we do create
37 ;; appropriate list structure for intermediate keys that can't be found
38 (unless (hash-table-p h
) (setf h
(make-hash-table :test
'equal
)))
39 (let* ((sub (gethash key h
))
41 (apply #'%put-hash-ref new-value sub more-keys
)
43 (progn (setf (gethash key h
) val
) h
)))
45 (define-setf-expander hash-ref
(place &rest props
47 ;; %put-ref may cons new structure or mutate its argument.
48 ;; all this magic is just so that we can
49 ;; (let ((l nil)) (setf (ref l :foo :bar) t))
50 (multiple-value-bind (temps values stores set get
)
51 (get-setf-expansion place env
)
52 (let ((newval (gensym))
53 (ptemps (loop for i in props collect
(gensym))))
54 (values `(,@temps
,@ptemps
)
57 `(let ((,(car stores
) (%put-hash-ref
,newval
,get
,@ptemps
)))
60 `(hash-ref ,get
,@ptemps
)))))