Commit fab0e59c authored by Philipp Marek's avatar Philipp Marek

Fixed issue 13, WHICHEVER and single-argument calls.

parent fc2a2f5c
...@@ -50,22 +50,27 @@ returns the values of T or OTHERWISE if no keys match." ...@@ -50,22 +50,27 @@ returns the values of T or OTHERWISE if no keys match."
(defmacro whichever (&rest possibilities &environment env) (defmacro whichever (&rest possibilities &environment env)
"Evaluates exactly one of POSSIBILITIES, chosen at random." "Evaluates exactly one of POSSIBILITIES, chosen at random."
(setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities)) (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
(if (every (lambda (p) (constantp p)) possibilities) (let ((length (length possibilities)))
`(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities))) (cond
(labels ((expand (possibilities position random-number) ((= 1 length)
(if (null (cdr possibilities)) (first possibilities))
(car possibilities) ((every #'constantp possibilities)
(let* ((length (length possibilities)) `(svref (load-time-value (vector ,@possibilities))
(half (truncate length 2)) (random ,length)))
(second-half (nthcdr half possibilities)) (T
(first-half (butlast possibilities (- length half)))) (labels ((expand (possibilities position random-number)
`(if (< ,random-number ,(+ position half)) (if (null (cdr possibilities))
,(expand first-half position random-number) (car possibilities)
,(expand second-half (+ position half) random-number)))))) (let* ((length (length possibilities))
(with-gensyms (random-number) (half (truncate length 2))
(let ((length (length possibilities))) (second-half (nthcdr half possibilities))
`(let ((,random-number (random ,length))) (first-half (butlast possibilities (- length half))))
,(expand possibilities 0 random-number))))))) `(if (< ,random-number ,(+ position half))
,(expand first-half position random-number)
,(expand second-half (+ position half) random-number))))))
(with-gensyms (random-number)
`(let ((,random-number (random ,length)))
,(expand possibilities 0 random-number))))))))
(defmacro xor (&rest datums) (defmacro xor (&rest datums)
"Evaluates its arguments one at a time, from left to right. If more than one "Evaluates its arguments one at a time, from left to right. If more than one
......
...@@ -188,6 +188,15 @@ ...@@ -188,6 +188,15 @@
(and (member x '(1 2 3)) t)) (and (member x '(1 2 3)) t))
t) t)
;; https://gitlab.common-lisp.net/alexandria/alexandria/issues/13
(deftest whichever.3
(multiple-value-bind (code warnings?)
(compile nil `(lambda (x)
(whichever (1+ x))))
(and (not warnings?)
(= 6 (funcall code 5))))
t)
(deftest xor.1 (deftest xor.1
(xor nil nil 1 nil) (xor nil nil 1 nil)
1 1
......
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