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."
(defmacro whichever (&rest possibilities &environment env)
"Evaluates exactly one of POSSIBILITIES, chosen at random."
(setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
(if (every (lambda (p) (constantp p)) possibilities)
`(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
(labels ((expand (possibilities position random-number)
(if (null (cdr possibilities))
(car possibilities)
(let* ((length (length possibilities))
(half (truncate length 2))
(second-half (nthcdr half possibilities))
(first-half (butlast possibilities (- length half))))
`(if (< ,random-number ,(+ position half))
,(expand first-half position random-number)
,(expand second-half (+ position half) random-number))))))
(with-gensyms (random-number)
(let ((length (length possibilities)))
`(let ((,random-number (random ,length)))
,(expand possibilities 0 random-number)))))))
(let ((length (length possibilities)))
(cond
((= 1 length)
(first possibilities))
((every #'constantp possibilities)
`(svref (load-time-value (vector ,@possibilities))
(random ,length)))
(T
(labels ((expand (possibilities position random-number)
(if (null (cdr possibilities))
(car possibilities)
(let* ((length (length possibilities))
(half (truncate length 2))
(second-half (nthcdr half possibilities))
(first-half (butlast possibilities (- length half))))
`(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)
"Evaluates its arguments one at a time, from left to right. If more than one
......
......@@ -188,6 +188,15 @@
(and (member x '(1 2 3)) 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
(xor nil nil 1 nil)
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