1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
6 (in-package :iolib.base
)
8 (defmacro multiple-value-case
((values &key
(test 'eql
)) &body body
)
9 (setf values
(ensure-list values
))
10 (when (symbolp test
) (setf test
`(quote ,test
)))
11 (assert values
() "Must provide at least one value to test")
12 (let ((test-name (alexandria::extract-function-name test
)))
13 (labels ((%do-var
(var val
)
15 ((and (symbolp var
) (member var
'("_" "*") :test
#'string
=))
18 `(member ,val
',var
:test
,test
))
20 `(,test-name
,val
',var
))))
21 (%do-clause
(c gensyms
)
22 (destructuring-bind (vals &rest code
) c
23 (let* ((tests (remove t
(mapcar #'%do-var
(ensure-list vals
) gensyms
)))
24 (clause-test (if (> 2 (length tests
))
27 `(,clause-test
,@code
))))
28 (%do-last-clause
(c gensyms
)
30 (destructuring-bind (test &rest code
) c
31 (if (member test
'(otherwise t
))
33 `(,(%do-clause c gensyms
)))))))
34 (let ((gensyms (mapcar (lambda (v) (gensym (string v
)))
36 `(let ,(mapcar #'list gensyms values
)
37 (declare (ignorable ,@gensyms
))
38 (cond ,@(append (mapcar (lambda (c) (%do-clause c gensyms
))
40 (%do-last-clause
(lastcar body
) gensyms
))))))))
42 (defmacro flags-case
(mask &body clauses
)
44 `(progn ,@(mapcar (lambda (clause)
46 (logtest ,(let ((flags (first clause
)))