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

KindCoveredAll%
expression051 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/macs/collecting.lisp --- Collecting Macros
2
 
3
 ;; ported from CL-UTILITIES
4
 
5
 ;;; Code:
6
 (in-package :std/macs)
7
 
8
 ;; This should only be called inside of COLLECTING macros, but we
9
 ;; define it here to provide an informative error message and to make
10
 ;; it easier for SLIME (et al.) to get documentation for the COLLECT
11
 ;; function when it's used in the COLLECTING macro.
12
 (defun collect (thing)
13
   "Collect THING in the context established by the COLLECTING macro"
14
   (error "Can't collect ~S outside the context of the COLLECTING macro"
15
          thing))
16
 
17
 (defmacro collecting (&body body)
18
   "Collect things into a list forwards. Within the body of this macro,
19
 the COLLECT function will collect its argument into the list returned
20
 by COLLECTING."
21
   (with-gensyms (collector tail)
22
     `(let (,collector ,tail)
23
       (labels ((collect (thing)
24
                  (if ,collector
25
                      (setf (cdr ,tail)
26
                            (setf ,tail (list thing)))
27
                      (setf ,collector
28
                            (setf ,tail (list thing))))))
29
         ,@body)
30
       ,collector)))
31
 
32
 (defmacro with-collectors ((&rest collectors) &body body)
33
   "Collect some things into lists forwards. The names in COLLECTORS
34
 are defined as local functions which each collect into a separate
35
 list.  Returns as many values as there are collectors, in the order
36
 they were given."
37
   (%with-collectors-check-collectors collectors)
38
   (let ((gensyms-alist (%with-collectors-gensyms-alist collectors)))
39
     `(let ,(loop for collector in collectors
40
                  for tail = (cdr (assoc collector gensyms-alist))
41
                  nconc (list collector tail))
42
       (labels ,(loop for collector in collectors
43
                      for tail = (cdr (assoc collector gensyms-alist))
44
                      collect `(,collector (thing)
45
                                (if ,collector
46
                                    (setf (cdr ,tail)
47
                                          (setf ,tail (list thing)))
48
                                    (setf ,collector
49
                                          (setf ,tail (list thing))))))
50
         ,@body)
51
       (values ,@collectors))))
52
 
53
 (defun %with-collectors-check-collectors (collectors)
54
   "Check that all of the COLLECTORS are symbols. If not, raise an error."
55
   (let ((bad-collector (find-if-not #'symbolp collectors)))
56
     (when bad-collector
57
       (error 'type-error
58
              :datum bad-collector
59
              :expected-type 'symbol))))
60
 
61
 (defun %with-collectors-gensyms-alist (collectors)
62
   "Return an alist mapping the symbols in COLLECTORS to gensyms"
63
   (mapcar #'cons collectors
64
           (mapcar (compose #'gensym
65
                            #'(lambda (x)
66
                                (format nil "~A-TAIL-" x)))
67
                   collectors)))