control-flow.lisp 5 KB
Newer Older
1 2
(in-package :alexandria)

3 4 5 6 7 8 9 10
(defun extract-function-name (spec)
  "Useful for macros that want to mimic the functional interface for functions
like #'eq and 'eq."
  (if (and (consp spec)
           (member (first spec) '(quote function)))
      (second spec)
      spec))

11
(defun generate-switch-body (whole object clauses test key &optional default)
12
  (with-gensyms (value)
13
    (setf test (extract-function-name test))
14
    (setf key (extract-function-name key))
15 16 17 18
    (when (and (consp default)
               (member (first default) '(error cerror)))
      (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
                      ,value ',test)))
19
    `(let ((,value (,key ,object)))
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
      (cond ,@(mapcar (lambda (clause)
                        (if (member (first clause) '(t otherwise))
                            (progn
                              (when default
                                (error "Multiple default clauses or illegal use of a default clause in ~S."
                                       whole))
                              (setf default `(progn ,@(rest clause)))
                              '(()))
                            (destructuring-bind (key-form &body forms) clause
                              `((,test ,value ,key-form)
                                ,@forms))))
                      clauses)
            (t ,default)))))

(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
                         &body clauses)
  "Evaluates first matching clause, returning its values, or evaluates and
returns the values of DEFAULT if no keys match."
  (generate-switch-body whole object clauses test key))
39

40 41
(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
                          &body clauses)
42
  "Like SWITCH, but signals an error if no key matches."
43
  (generate-switch-body whole object clauses test key '(error)))
44

45 46
(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
                          &body clauses)
47
  "Like SWITCH, but signals a continuable error if no key matches."
48
  (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
49

Nikodemus Siivola's avatar
Nikodemus Siivola committed
50
(defmacro whichever (&rest possibilities &environment env)
51
  "Evaluates exactly one of POSSIBILITIES, chosen at random."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
52 53 54
  (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)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
55 56 57 58 59 60 61 62 63 64 65 66 67 68
      (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)))))))
69 70

(defmacro xor (&rest datums)
Steve Losh's avatar
Steve Losh committed
71
  "Evaluates its arguments one at a time, from left to right. If more than one
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
argument evaluates to a true value no further DATUMS are evaluated, and NIL is
returned as both primary and secondary value. If exactly one argument
evaluates to true, its value is returned as the primary value after all the
arguments have been evaluated, and T is returned as the secondary value. If no
arguments evaluate to true NIL is retuned as primary, and T as secondary
value."
  (with-gensyms (xor tmp true)
    `(let (,tmp ,true)
       (block ,xor
         ,@(mapcar (lambda (datum)
                     `(if (setf ,tmp ,datum)
                          (if ,true
                              (return-from ,xor (values nil nil))
                              (setf ,true ,tmp))))
                   datums)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
87 88 89 90
         (return-from ,xor (values ,true t))))))

(defmacro nth-value-or (nth-value &body forms)
  "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
91 92
of the forms is true. It then returns all the values returned by evaluating
that form. If none of the forms return a true nth value, this form returns
Nikodemus Siivola's avatar
Nikodemus Siivola committed
93 94 95 96 97 98 99 100 101
NIL."
  (once-only (nth-value)
    (with-gensyms (values)
      `(let ((,values (multiple-value-list ,(first forms))))
         (if (nth ,nth-value ,values)
             (values-list ,values)
             ,(if (rest forms)
                  `(nth-value-or ,nth-value ,@(rest forms))
                  nil))))))
102

103 104 105 106
(defmacro multiple-value-prog2 (first-form second-form &body forms)
  "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value
all the value returned by SECOND-FORM."
  `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))