control-flow.lisp

   1 (in-package :alexandria)
   2
   3 (defun generate-switch-body (whole object clauses test key &optional default)
   4   (with-gensyms (value)
   5     (setf test (extract-function-name test))
   6     (setf key (extract-function-name key))
   7     (when (and (consp default)
   8                (member (first default) '(error cerror)))
   9       (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
  10                       ,value ',test)))
  11     `(let ((,value (,key ,object)))
  12       (cond ,@(mapcar (lambda (clause)
  13                         (if (member (first clause) '(t otherwise))
  14                             (progn
  15                               (when default
  16                                 (error "Multiple default clauses or illegal use of a default clause in ~S."
  17                                        whole))
  18                               (setf default `(progn ,@(rest clause)))
  19                               '(()))
  20                             (destructuring-bind (key-form &body forms) clause
  21                               `((,test ,value ,key-form)
  22                                 ,@forms))))
  23                       clauses)
  24             (t ,default)))))
  25
  26 (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
  27                          &body clauses)
  28   "Evaluates first matching clause, returning its values, or evaluates and
  29 returns the values of DEFAULT if no keys match."
  30   (generate-switch-body whole object clauses test key))
  31
  32 (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
  33                           &body clauses)
  34   "Like SWITCH, but signals an error if no key matches."
  35   (generate-switch-body whole object clauses test key '(error)))
  36
  37 (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
  38                           &body clauses)
  39   "Like SWITCH, but signals a continuable error if no key matches."
  40   (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
  41
  42 (defmacro whichever (&rest possibilities &environment env)
  43   "Evaluates exactly one of POSSIBILITIES, chosen at random."
  44   (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
  45   (if (every (lambda (p) (constantp p)) possibilities)
  46       `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
  47       (with-gensyms (function)
  48         `(let ((,function (lambda () ,(pop possibilities))))
  49            (declare (function ,function))
  50            ,@(let ((p 1))
  51                (mapcar (lambda (possibility)
  52                          `(when (zerop (random ,(incf p)))
  53                             (setf ,function (lambda () ,possibility))))
  54                        possibilities))
  55            (funcall ,function)))))
  56
  57 (defmacro xor (&rest datums)
  58   "Evaluates its argument one at a time, from left to right. If more then one
  59 argument evaluates to a true value no further DATUMS are evaluated, and NIL is
  60 returned as both primary and secondary value. If exactly one argument
  61 evaluates to true, its value is returned as the primary value after all the
  62 arguments have been evaluated, and T is returned as the secondary value. If no
  63 arguments evaluate to true NIL is retuned as primary, and T as secondary
  64 value."
  65   (with-gensyms (xor tmp true)
  66     `(let (,tmp ,true)
  67        (block ,xor
  68          ,@(mapcar (lambda (datum)
  69                      `(if (setf ,tmp ,datum)
  70                           (if ,true
  71                               (return-from ,xor (values nil nil))
  72                               (setf ,true ,tmp))))
  73                    datums)
  74          (return-from ,xor (values ,true t))))))
  75
  76 (defmacro nth-value-or (nth-value &body forms)
  77   "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
  78 of the forms is non-NIL. It then returns all the values returned by evaluating
  79 that form. If none of the forms return a non-nil nth value, this form returns
  80 NIL."
  81   (once-only (nth-value)
  82     (with-gensyms (values)
  83       `(let ((,values (multiple-value-list ,(first forms))))
  84          (if (nth ,nth-value ,values)
  85              (values-list ,values)
  86              ,(if (rest forms)
  87                   `(nth-value-or ,nth-value ,@(rest forms))
  88                   nil))))))