Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
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 singleargument calls.
parent
fc2a2f5c
Changes
2
Hide whitespace changes
Inline
Sidebyside
controlflow.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
(
loadtimevalue
(
vector
,@
possibilities
))
(
random
,
(
length
possibilities
)))
(
labels
((
expand
(
possibilities
position
randomnumber
)
(
if
(
null
(
cdr
possibilities
))
(
car
possibilities
)
(
let*
((
length
(
length
possibilities
))
(
half
(
truncate
length
2
))
(
secondhalf
(
nthcdr
half
possibilities
))
(
firsthalf
(
butlast
possibilities
(

length
half
))))
`
(
if
(
<
,
randomnumber
,
(
+
position
half
))
,
(
expand
firsthalf
position
randomnumber
)
,
(
expand
secondhalf
(
+
position
half
)
randomnumber
))))))
(
withgensyms
(
randomnumber
)
(
let
((
length
(
length
possibilities
)))
`
(
let
((
,
randomnumber
(
random
,
length
)))
,
(
expand
possibilities
0
randomnumber
)))))))
(
let
((
length
(
length
possibilities
)))
(
cond
((
=
1
length
)
(
first
possibilities
))
((
every
#'
constantp
possibilities
)
`
(
svref
(
loadtimevalue
(
vector
,@
possibilities
))
(
random
,
length
)))
(
T
(
labels
((
expand
(
possibilities
position
randomnumber
)
(
if
(
null
(
cdr
possibilities
))
(
car
possibilities
)
(
let*
((
length
(
length
possibilities
))
(
half
(
truncate
length
2
))
(
secondhalf
(
nthcdr
half
possibilities
))
(
firsthalf
(
butlast
possibilities
(

length
half
))))
`
(
if
(
<
,
randomnumber
,
(
+
position
half
))
,
(
expand
firsthalf
position
randomnumber
)
,
(
expand
secondhalf
(
+
position
half
)
randomnumber
))))))
(
withgensyms
(
randomnumber
)
`
(
let
((
,
randomnumber
(
random
,
length
)))
,
(
expand
possibilities
0
randomnumber
))))))))
(
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.commonlisp.net/alexandria/alexandria/issues/13
(
deftest
whichever.3
(
multiplevaluebind
(
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
Supports
Markdown
0%
Try again
or
attach a new 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