Coverage report: /home/ellis/comp/core/std/macs/control.lisp

KindCoveredAll%
expression081 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/macs/control.lisp --- Control Flow Macros
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :std/macs)
7
 
8
 ;; From ALEXANDRIA
9
 (defun extract-function-name (spec)
10
   "Useful for macros that want to mimic the functional interface for functions
11
 like #'eq and 'eq."
12
   (if (and (consp spec)
13
            (member (first spec) '(quote function)))
14
       (second spec)
15
       spec))
16
 
17
 (defun generate-switch-body (whole object clauses test key &optional default)
18
   (with-gensyms (value)
19
     (setf test (extract-function-name test))
20
     (setf key (extract-function-name key))
21
     (when (and (consp default)
22
                (member (first default) '(error cerror)))
23
       (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
24
                       ,value ',test)))
25
     `(let ((,value (,key ,object)))
26
       (cond ,@(mapcar (lambda (clause)
27
                         (if (member (first clause) '(t otherwise))
28
                             (progn
29
                               (when default
30
                                 (error "Multiple default clauses or illegal use of a default clause in ~S."
31
                                        whole))
32
                               (setf default `(progn ,@(rest clause)))
33
                               '(()))
34
                             (destructuring-bind (key-form &body forms) clause
35
                               `((,test ,value ,key-form)
36
                                 ,@forms))))
37
                       clauses)
38
             (t ,default)))))
39
 
40
 (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
41
                          &body clauses)
42
   "Evaluates first matching clause, returning its values, or evaluates and
43
 returns the values of T or OTHERWISE if no keys match."
44
   (generate-switch-body whole object clauses test key))
45
 
46
 (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
47
                           &body clauses)
48
   "Like SWITCH, but signals an error if no key matches."
49
   (generate-switch-body whole object clauses test key '(error)))
50
 
51
 (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
52
                           &body clauses)
53
   "Like SWITCH, but signals a continuable error if no key matches."
54
   (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
55
 
56
 (defmacro xor (&rest datums)
57
   "Evaluates its arguments one at a time, from left to right. If more than one
58
 argument evaluates to a true value no further DATUMS are evaluated, and NIL is
59
 returned as both primary and secondary value. If exactly one argument
60
 evaluates to true, its value is returned as the primary value after all the
61
 arguments have been evaluated, and T is returned as the secondary value. If no
62
 arguments evaluate to true NIL is returned as primary, and T as secondary
63
 value."
64
   (with-gensyms (xor tmp true)
65
     `(let (,tmp ,true)
66
        (declare (ignorable ,tmp))
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
 ;; From ELEPHANT
77
 (defmacro ifret (pred &body alt)
78
   "If pred is non-null, return the value, otherwise return the alternate value"
79
   (once-only (pred)
80
     `(if ,pred ,pred (progn ,@alt))))