kutils/kutils-hash-tables.lisp

109 lines
2.9 KiB
Common Lisp

(in-package #:kutils)
;;; hash-table functions.
(defun |#{-reader| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((m (make-hash-table :test 'equal))
(k nil)
(v nil)
(key-p t))
(labels ((finalise-read (x)
(reverse (concatenate 'string x)))
(finalise-kv-pair ()
(if key-p
(unless (null k)
(setq key-p nil
k (read-from-string (finalise-read k))))
(unless (null v)
(setq key-p t
v (read-from-string (finalise-read v)))
(setf (gethash k m) v)
(setq k nil v nil))))
(reading-complete-p ()
(and (null v)
(not
(null k)))))
(do ((prev (read-char stream) curr)
(curr (read-char stream) (read-char stream)))
((and (char= prev #\}) (char= curr #\#)))
(if (char= prev #\Space)
(finalise-kv-pair)
(if key-p
(push prev k)
(push prev v))))
(if (reading-complete-p)
(error "Mismatched key value pairs.")
(progn
(finalise-kv-pair)
m)))))
(defun enable-hash-table-reader ()
"Enables the reader macro #{}# for hash-tables. The resulting
hash-table will use #'equal for equality. For example,
#{:a :b :c :d}#
will create a hash-table with the keys :a and :c. :a stores the
value :b, and :c stores the value :d.
"
(set-dispatch-macro-character
#\# #\{ #'|#{-reader|))
(defun sethash (k v m)
"Convenience notation for setting a value in a hash table."
(setf (gethash k m) v))
(defun hashkeys (m)
"Returns a list of the keys in the hash table."
(let ((keys '()))
(maphash (lambda (k v)
(declare (ignore v))
(push k keys))
m)
keys))
(defun hash-table-to-alist (m)
"Converts the hash-table given to an alist of (key . value) pairs."
(let ((alist '()))
(maphash (lambda (k v)
(let ((elt (cons k v)))
(setf alist (cons elt alist))))
m)
alist))
(defun alist-to-hash-table (alist)
"Converts the alist to a hash-table."
(let ((m (make-hash-table :test 'equal)))
(dolist (elt alist)
(sethash (car elt) (cdr elt) m))
m))
(defun copy-hash-table (ht)
(let ((copied (make-hash-table :equal #'equal)))
(maphash (lambda (k v)
(sethash k v copied))
ht)
copied))
(defun new-hash-table ()
"Create a new hash table with the #'equal function as its test."
(make-hash-table :test #'equal))
(defmacro with-new-hash-table (htsyms &body body)
"with-new-hash-table creates and binds a new hash table for each of
the symbols in htsyms, executing inside a let form, and returns the
hash table(s). If only one hash table is provided, return it as a
single element; otherwise, return an alist of the symbol names and
hash tables."
`(let ,(mapcar (lambda (sym)
(list sym (list 'new-hash-table))) htsyms)
,@body
,(if (null (rest htsyms))
(first htsyms)
`(mapcar #'cons
(mapcar #'mksymb (quote ,htsyms))
(list ,@htsyms)))))