external/ch-util/src/hash-table.cl

   1 ;;;
   2 ;;; hash-table.cl -- various lisp utilities for hash-tables
   3 ;;;
   4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
   5 ;;;
   6
   7 (in-package :ch-util)
   8
   9 ;;; Miscellaneous hash-table utilities
  10
  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))
  15     h))
  16
  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))
  21     h))
  22
  23 (defun hash-table-to-plist (h &aux l)
  24   (if (hash-table-p h)
  25       (progn (maphash
  26               #'(lambda (key val)
  27                   (setf l (cons (hash-table-to-plist val)
  28                                 (cons key l)))) h)
  29              (nreverse l))
  30       h))
  31
  32 (defun hash-ref (h &rest keys)
  33   (reduce #'(lambda (h k) (gethash k h)) keys :initial-value h))
  34
  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))
  40          (val (if more-keys
  41                   (apply #'%put-hash-ref new-value sub more-keys)
  42                   new-value)))
  43     (progn (setf (gethash key h) val) h)))
  44
  45 (define-setf-expander hash-ref (place &rest props
  46                                   &environment env)
  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 )
  55               `(,@values ,@props )
  56               `(,newval)
  57               `(let ((,(car stores) (%put-hash-ref ,newval ,get ,@ptemps)))
  58                  ,set
  59                  ,newval)
  60               `(hash-ref ,get ,@ptemps)))))