hash-tables.lisp 3.67 KB
Newer Older
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1
2
(in-package :alexandria)

3
4
5
(defun copy-hash-table (table &key key test size
                                   rehash-size rehash-threshold)
  "Returns a copy of hash table TABLE, with the same keys and values
Nikodemus Siivola's avatar
Nikodemus Siivola committed
6
as the TABLE. The copy has the same properties as the original, unless
7
8
9
10
11
12
13
14
overridden by the keyword arguments.

Before each of the original values is set into the new hash-table, KEY
is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow
copy is returned by default."
  (setf key (or key 'identity))
  (setf test (or test (hash-table-test table)))
  (setf size (or size (hash-table-size table)))
Luís Oliveira's avatar
Luís Oliveira committed
15
  (setf rehash-size (or rehash-size (hash-table-rehash-size table)))
16
  (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
17
18
  (let ((copy (make-hash-table :test test :size size
                               :rehash-size rehash-size
Nikodemus Siivola's avatar
Nikodemus Siivola committed
19
20
                               :rehash-threshold rehash-threshold)))
    (maphash (lambda (k v)
21
               (setf (gethash k copy) (funcall key v)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
             table)
    copy))

(declaim (inline maphash-keys))
(defun maphash-keys (function table)
  "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
  (maphash (lambda (k v)
             (declare (ignore v))
             (funcall function k))
           table))

(declaim (inline maphash-values))
(defun maphash-values (function table)
  "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
  (maphash (lambda (k v)
             (declare (ignore k))
             (funcall function v))
           table))

(defun hash-table-keys (table)
  "Returns a list containing the keys of hash table TABLE."
  (let ((keys nil))
    (maphash-keys (lambda (k)
                    (push k keys))
                  table)
    keys))

(defun hash-table-values (table)
  "Returns a list containing the values of hash table TABLE."
  (let ((values nil))
    (maphash-values (lambda (v)
                      (push v values))
                    table)
    values))

(defun hash-table-alist (table)
  "Returns an association list containing the keys and values of hash table
TABLE."
  (let ((alist nil))
    (maphash (lambda (k v)
               (push (cons k v) alist))
             table)
    alist))

(defun hash-table-plist (table)
  "Returns a property list containing the keys and values of hash table
TABLE."
  (let ((plist nil))
    (maphash (lambda (k v)
               (setf plist (list* k v plist)))
             table)
    plist))

(defun alist-hash-table (alist &rest hash-table-initargs)
  "Returns a hash table containing the keys and values of the association list
ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
  (let ((table (apply #'make-hash-table hash-table-initargs)))
    (dolist (cons alist)
      (setf (gethash (car cons) table) (cdr cons)))
    table))

(defun plist-hash-table (plist &rest hash-table-initargs)
  "Returns a hash table containing the keys and values of the property list
PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
  (let ((table (apply #'make-hash-table hash-table-initargs)))
    (do ((tail plist (cddr tail)))
        ((not tail))
      (setf (gethash (car tail) table) (cadr tail)))
    table))

92
(defmacro ensure-gethash (key hash-table &optional default)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
93
94
95
  "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
under key before returning it. Secondary return value is true if key was
already in the table."
96
97
98
99
100
101
  (once-only (key hash-table)
    (with-unique-names (value presentp)
      `(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table)
         (if ,presentp
             (values ,value ,presentp)
             (values (setf (gethash ,key ,hash-table) ,default) nil))))))