control-flow.lisp

   1 (in-package :alexandria)
   2
   3 (defmacro switch ((object &key (test 'eql) (key 'identity) (default nil))
   4                   &body clauses)
   5   "Evaluates first matching clause, returning its values, or evaluates and
   6 returns the values of DEFAULT if no keys match."
   7   (with-gensyms (value)
   8     `(let ((,value (,key ,object)))
   9        (cond ,@(mapcar (lambda (clause)
  10                          (destructuring-bind (key-form &body forms) clause
  11                            `((,test ,value ,key-form)
  12                              ,@forms)))
  13                        clauses)
  14              (t ,default)))))
  15
  16 (defmacro eswitch ((object &key (test 'eql) (key 'identity)) &body clauses)
  17   "Like SWITCH, but signals an error if no key matches."
  18   (with-gensyms (value)
  19     `(let ((,value (,key ,object)))
  20        (cond ,@(mapcar (lambda (clause)
  21                          (destructuring-bind (key-form &body forms) clause
  22                            `((,test ,value ,key-form)
  23                              ,@forms)))
  24                        clauses)
  25              (t
  26               (error "No keys match in ESWITCH. Testing against ~S with ~S."
  27                      ,value ',test))))))
  28
  29 (defmacro cswitch ((object &key (test 'eql) (key 'identity)) &body clauses)
  30   "Like SWITCH, but signals a continuable error if no key matches."
  31   (with-gensyms (value)
  32     `(let ((,value (,key ,object)))
  33        (cond ,@(mapcar (lambda (clause)
  34                          (destructuring-bind (key-form &body forms) clause
  35                            `((,test ,value ,key-form)
  36                              ,@forms)))
  37                        clauses)
  38              (t
  39               (cerror "Return NIL from CSWITCH."
  40                "No keys match in CSWITCH. Testing against ~S with ~S."
  41                ,value ',test))))))
  42
  43 (defmacro whichever (&rest possibilities)
  44   "Evaluates exactly one of POSSIBILITIES, chosen at random."
  45   `(funcall (the function
  46               (svref (load-time-value
  47                       (vector ,@(mapcar (lambda (possibility)
  48                                           `(lambda () ,possibility))
  49                                         possibilities))
  50                       t)
  51                      (random ,(length possibilities))))))
  52
  53 (defmacro xor (&rest datums)
  54   "Evaluates its argument one at a time, from left to right. If more then one
  55 argument evaluates to a true value no further DATUMS are evaluated, and NIL is
  56 returned as both primary and secondary value. If exactly one argument
  57 evaluates to true, its value is returned as the primary value after all the
  58 arguments have been evaluated, and T is returned as the secondary value. If no
  59 arguments evaluate to true NIL is retuned as primary, and T as secondary
  60 value."
  61   (with-gensyms (xor tmp true)
  62     `(let (,tmp ,true)
  63        (block ,xor
  64          ,@(mapcar (lambda (datum)
  65                      `(if (setf ,tmp ,datum)
  66                           (if ,true
  67                               (return-from ,xor (values nil nil))
  68                               (setf ,true ,tmp))))
  69                    datums)
  70          (return-from ,xor (values ,true t))))))