Squashed 'third_party/lisp/alexandria/' content from commit fc2a2f5c

git-subtree-dir: third_party/lisp/alexandria
git-subtree-split: fc2a2f5c34147bb4e3e4a350b04220de0263710f

1 files changed, 101 insertions, 0 deletions

diff --git a/hash-tables.lisp b/hash-tables.lisp
new file mode 100644
index 000000000000..a9f790220405
--- /dev/null
+++ b/hash-tables.lisp
@@ -0,0 +1,101 @@
+(in-package :alexandria)
+
+(defmacro ensure-gethash (key hash-table &optional default)
+  "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."
+  (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))))))
+
+(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
+as the TABLE. The copy has the same properties as the original, unless
+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)))
+  (setf rehash-size (or rehash-size (hash-table-rehash-size table)))
+  (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
+  (let ((copy (make-hash-table :test test :size size
+                               :rehash-size rehash-size
+                               :rehash-threshold rehash-threshold)))
+    (maphash (lambda (k v)
+               (setf (gethash k copy) (funcall key v)))
+             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)
+      (ensure-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))
+      (ensure-gethash (car tail) table (cadr tail)))
+    table))