Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Gábor Melis
alexandria
Commits
fab0e59c
Commit
fab0e59c
authored
Jan 25, 2020
by
Philipp Marek
Browse files
Fixed issue 13, WHICHEVER and single-argument calls.
parent
fc2a2f5c
Changes
2
Hide whitespace changes
Inline
Side-by-side
control-flow.lisp
View file @
fab0e59c
...
...
@@ -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
...
...
tests.lisp
View file @
fab0e59c
...
...
@@ -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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment