Coverage report: /home/ellis/comp/ext/ironclad/src/macro-utils.lisp

KindCoveredAll%
expression17129 13.2
branch316 18.8
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; macro-utils.lisp -- things to make compiler macros easier
2
 (in-package :crypto)
3
 
4
 (defun quotationp (thing)
5
   (and (consp thing) (consp (rest thing))
6
        (null (cddr thing)) (eq (first thing) 'quote)))
7
 
8
 (defun unquote (thing)
9
   (if (quotationp thing) (second thing) thing))
10
 
11
 (defun massage-symbol (symbol)
12
   (let ((package (symbol-package symbol))
13
         (ironclad (load-time-value (find-package :ironclad))))
14
     (cond
15
       ((eq package ironclad) symbol)
16
       ((eq package (load-time-value (find-package :keyword)))
17
        (find-symbol (symbol-name symbol) ironclad))
18
       (t nil))))
19
 
20
 ;;; a few functions that are useful during compilation
21
 (defun make-circular-list (&rest elements)
22
   (let ((list (copy-seq elements)))
23
     (setf (cdr (last list)) list)))
24
 
25
 ;;; SUBSEQ is defined to error on circular lists, so we define our own
26
 (defun circular-list-subseq (list start end)
27
   (let* ((length (- end start))
28
          (subseq (make-list length)))
29
     (do ((i 0 (1+ i))
30
          (list (nthcdr start list) (cdr list))
31
          (xsubseq subseq (cdr xsubseq)))
32
         ((>= i length) subseq)
33
       (setf (first xsubseq) (first list)))))
34
 
35
 ;;; Partial evaluation helpers
36
 (eval-when (:compile-toplevel :load-toplevel :execute)
37
   (defun trivial-macroexpand-all (form env)
38
     "Trivial and very restricted code-walker used in partial evaluation macros.
39
 Only supports atoms and function forms, no special forms."
40
     (let ((real-form (macroexpand form env)))
41
       (cond
42
         ((atom real-form)
43
          real-form)
44
         (t
45
          (list* (car real-form)
46
                 (mapcar #'(lambda (x) (trivial-macroexpand-all x env))
47
                         (cdr real-form))))))))
48
 
49
 (defmacro dotimes-unrolled ((var limit) &body body &environment env)
50
   "Unroll the loop body at compile-time."
51
   (loop for x from 0 below (eval (trivial-macroexpand-all limit env))
52
         collect `(symbol-macrolet ((,var ,x)) ,@body) into forms
53
         finally (return `(progn ,@forms))))
54
 
55
 (defun symbolicate (&rest things)
56
   "Concatenate together the names of some strings and symbols,
57
 producing a symbol in the current package."
58
   (flet ((stringify (x)
59
            (typecase x
60
              (integer (format nil "~D" x))
61
              (t (string x)))))
62
     (let* ((length (reduce #'+ things
63
                            :key (lambda (x) (length (stringify x)))))
64
            (name (make-array length :element-type 'character)))
65
       (let ((index 0))
66
         (dolist (thing things (values (intern name)))
67
           (let* ((x (stringify thing))
68
                  (len (length x)))
69
             (replace name x :start1 index)
70
             (incf index len)))))))