Commit 8b6d82d3 authored by NicolasPetton's avatar NicolasPetton
Browse files

Define `map-elt' as a generalized variable

* lisp/emacs-lisp/map.el (map-elt): Define a gv-expander.

* lisp/emacs-lisp/map.el (map--dispatch): Tighten the code.

* lisp/emacs-lisp/map.el (map-put): Redefine it as a function using a
`setf' with `map-elt'.

* test/automated/map-tests.el: Comment out `test-map-put-literal'.
parent 8d4f1e3b
......@@ -82,25 +82,21 @@ The following keyword types are meaningful: `:list',
An error is thrown if MAP is neither a list, hash-table nor array.
Return RESULT if non-nil or the result of evaluation of the
form.
Return RESULT if non-nil or the result of evaluation of the form.
\(fn (VAR MAP [RESULT]) &rest ARGS)"
(declare (debug t) (indent 1))
(unless (listp spec)
(setq spec `(,spec ,spec)))
(let ((map-var (car spec))
(result-var (make-symbol "result")))
`(let ((,map-var ,(cadr spec))
,result-var)
(setq ,result-var
(cond ((listp ,map-var) ,(plist-get args :list))
((hash-table-p ,map-var) ,(plist-get args :hash-table))
((arrayp ,map-var) ,(plist-get args :array))
(t (error "Unsupported map: %s" ,map-var))))
,@(when (cddr spec)
`((setq ,result-var ,@(cddr spec))))
,result-var)))
(let ((map-var (car spec)))
`(let* ,(unless (eq map-var (cadr spec)) `((,map-var ,(cadr spec))))
(cond ((listp ,map-var) ,(plist-get args :list))
((hash-table-p ,map-var) ,(plist-get args :hash-table))
((arrayp ,map-var) ,(plist-get args :array))
(t (error "Unsupported map: %s" ,map-var)))
,@(cddr spec))))
(put 'map--raw-place 'gv-expander #'funcall)
(defun map-elt (map key &optional default)
"Perform a lookup in MAP of KEY and return its associated value.
......@@ -109,26 +105,34 @@ If KEY is not found, return DEFAULT which defaults to nil.
If MAP is a list, `eql' is used to lookup KEY.
MAP can be a list, hash-table or array."
(declare
(gv-expander
(lambda (do)
(gv-letplace (mgetter msetter) map
(macroexp-let2* nil
;; Eval them once and for all in the right order.
((key key) (default default))
`(map--dispatch ,mgetter
:list ,(gv-get `(alist-get ,key (map--raw-place ,mgetter ,msetter)
,default)
do)
:hash-table ,(gv-get `(gethash ,key (map--raw-place ,mgetter ,msetter)
,default))
:array ,(gv-get (aref (map--raw-place ,mgetter ,msetter) ,key)
do)))))))
(map--dispatch map
:list (alist-get key map default)
:hash-table (gethash key map default)
:array (map--elt-array map key default)))
(defmacro map-put (map key value)
(defun map-put (map key value)
"In MAP, associate KEY with VALUE and return MAP.
If KEY is already present in MAP, replace the associated value
with VALUE.
MAP can be a list, hash-table or array."
(declare (debug t))
(let ((symbol (symbolp map)))
`(progn
(map--dispatch (m ,map m)
:list (if ,symbol
(setq ,map (cons (cons ,key ,value) m))
(error "Literal lists are not allowed, %s must be a symbol" ',map))
:hash-table (puthash ,key ,value m)
:array (aset m ,key ,value)))))
(setf (map-elt map key) value)
map)
(defmacro map-delete (map key)
"In MAP, delete the key KEY if present and return MAP.
......
......@@ -40,11 +40,11 @@ Evaluate BODY for each created map.
(let ((alist (make-symbol "alist"))
(vec (make-symbol "vec"))
(ht (make-symbol "ht")))
`(let ((,alist '((0 . 3)
(1 . 4)
(2 . 5)))
(,vec (make-vector 3 nil))
(,ht (make-hash-table)))
`(let ((,alist (list (cons 0 3)
(cons 1 4)
(cons 2 5)))
(,vec (make-vector 3 nil))
(,ht (make-hash-table)))
(aset ,vec 0 '3)
(aset ,vec 1 '4)
(aset ,vec 2 '5)
......@@ -87,13 +87,13 @@ Evaluate BODY for each created map.
(let ((vec [3 4 5]))
(should-error (map-put vec 3 6))))
(ert-deftest test-map-put-literal ()
(should (= (map-elt (map-put [1 2 3] 1 4) 1)
4))
(should (= (map-elt (map-put (make-hash-table) 'a 2) 'a)
2))
(should-error (map-put '((a . 1)) 'b 2))
(should-error (map-put '() 'a 1)))
;; (ert-deftest test-map-put-literal ()
;; (should (= (map-elt (map-put [1 2 3] 1 4) 1)
;; 4))
;; (should (= (map-elt (map-put (make-hash-table) 'a 2) 'a)
;; 2))
;; (should-error (map-put '((a . 1)) 'b 2))
;; (should-error (map-put '() 'a 1)))
(ert-deftest test-map-put-return-value ()
(let ((ht (make-hash-table)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment