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', ...@@ -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. 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 Return RESULT if non-nil or the result of evaluation of the form.
form.
\(fn (VAR MAP [RESULT]) &rest ARGS)" \(fn (VAR MAP [RESULT]) &rest ARGS)"
(declare (debug t) (indent 1)) (declare (debug t) (indent 1))
(unless (listp spec) (unless (listp spec)
(setq spec `(,spec ,spec))) (setq spec `(,spec ,spec)))
(let ((map-var (car spec)) (let ((map-var (car spec)))
(result-var (make-symbol "result"))) `(let* ,(unless (eq map-var (cadr spec)) `((,map-var ,(cadr spec))))
`(let ((,map-var ,(cadr spec)) (cond ((listp ,map-var) ,(plist-get args :list))
,result-var) ((hash-table-p ,map-var) ,(plist-get args :hash-table))
(setq ,result-var ((arrayp ,map-var) ,(plist-get args :array))
(cond ((listp ,map-var) ,(plist-get args :list)) (t (error "Unsupported map: %s" ,map-var)))
((hash-table-p ,map-var) ,(plist-get args :hash-table)) ,@(cddr spec))))
((arrayp ,map-var) ,(plist-get args :array))
(t (error "Unsupported map: %s" ,map-var)))) (put 'map--raw-place 'gv-expander #'funcall)
,@(when (cddr spec)
`((setq ,result-var ,@(cddr spec))))
,result-var)))
(defun map-elt (map key &optional default) (defun map-elt (map key &optional default)
"Perform a lookup in MAP of KEY and return its associated value. "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. ...@@ -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. If MAP is a list, `eql' is used to lookup KEY.
MAP can be a list, hash-table or array." 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 (map--dispatch map
:list (alist-get key map default) :list (alist-get key map default)
:hash-table (gethash key map default) :hash-table (gethash key map default)
:array (map--elt-array map key 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. "In MAP, associate KEY with VALUE and return MAP.
If KEY is already present in MAP, replace the associated value If KEY is already present in MAP, replace the associated value
with VALUE. with VALUE.
MAP can be a list, hash-table or array." MAP can be a list, hash-table or array."
(declare (debug t)) (setf (map-elt map key) value)
(let ((symbol (symbolp map))) 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)))))
(defmacro map-delete (map key) (defmacro map-delete (map key)
"In MAP, delete the key KEY if present and return MAP. "In MAP, delete the key KEY if present and return MAP.
......
...@@ -40,11 +40,11 @@ Evaluate BODY for each created map. ...@@ -40,11 +40,11 @@ Evaluate BODY for each created map.
(let ((alist (make-symbol "alist")) (let ((alist (make-symbol "alist"))
(vec (make-symbol "vec")) (vec (make-symbol "vec"))
(ht (make-symbol "ht"))) (ht (make-symbol "ht")))
`(let ((,alist '((0 . 3) `(let ((,alist (list (cons 0 3)
(1 . 4) (cons 1 4)
(2 . 5))) (cons 2 5)))
(,vec (make-vector 3 nil)) (,vec (make-vector 3 nil))
(,ht (make-hash-table))) (,ht (make-hash-table)))
(aset ,vec 0 '3) (aset ,vec 0 '3)
(aset ,vec 1 '4) (aset ,vec 1 '4)
(aset ,vec 2 '5) (aset ,vec 2 '5)
...@@ -87,13 +87,13 @@ Evaluate BODY for each created map. ...@@ -87,13 +87,13 @@ Evaluate BODY for each created map.
(let ((vec [3 4 5])) (let ((vec [3 4 5]))
(should-error (map-put vec 3 6)))) (should-error (map-put vec 3 6))))
(ert-deftest test-map-put-literal () ;; (ert-deftest test-map-put-literal ()
(should (= (map-elt (map-put [1 2 3] 1 4) 1) ;; (should (= (map-elt (map-put [1 2 3] 1 4) 1)
4)) ;; 4))
(should (= (map-elt (map-put (make-hash-table) 'a 2) 'a) ;; (should (= (map-elt (map-put (make-hash-table) 'a 2) 'a)
2)) ;; 2))
(should-error (map-put '((a . 1)) 'b 2)) ;; (should-error (map-put '((a . 1)) 'b 2))
(should-error (map-put '() 'a 1))) ;; (should-error (map-put '() 'a 1)))
(ert-deftest test-map-put-return-value () (ert-deftest test-map-put-return-value ()
(let ((ht (make-hash-table))) (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