Coverage report: /home/ellis/comp/ext/ironclad/src/macs/mac.lisp

KindCoveredAll%
expression052 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; macs.lisp -- common functions for message authentication codes
2
 (in-package :crypto)
3
 
4
 (defclass mac () ())
5
 
6
 (defun macp (sym)
7
   (get sym '%make-mac))
8
 
9
 (defun list-all-macs ()
10
   (loop for symbol being each external-symbol of (find-package :ironclad)
11
         if (macp symbol)
12
           collect (intern (symbol-name symbol) :keyword) into macs
13
         finally (return (sort macs #'string<))))
14
 
15
 (defun mac-supported-p (name)
16
   "Return T if the mac NAME is a valid mac name."
17
   (and (symbolp name)
18
        (not (null (macp (massage-symbol name))))))
19
 
20
 (defmacro defmac (name maker updater producer)
21
   `(progn
22
      (setf (get ',name '%make-mac) #',maker)
23
 
24
      (defmethod update-mac ((mac ,name) (sequence vector) &key (start 0) (end (length sequence)))
25
        (check-type sequence simple-octet-vector)
26
        (check-type start index)
27
        (check-type end index)
28
        (,updater mac sequence :start start :end end)
29
        (values))
30
 
31
      (defmethod produce-mac ((mac ,name) &key digest (digest-start 0))
32
        (let* ((mac-digest (,producer mac))
33
               (digest-size (length mac-digest)))
34
          (etypecase digest
35
            (simple-octet-vector
36
             (if (<= digest-size (- (length digest) digest-start))
37
                 (replace digest mac-digest :start1 digest-start)
38
                 (error 'insufficient-buffer-space
39
                        :buffer digest
40
                        :start digest-start
41
                        :length digest-size)))
42
            (null
43
             mac-digest))))))
44
 
45
 (defun make-mac (mac-name key &rest args)
46
   "Return a MAC object which uses the algorithm MAC-NAME
47
 initialized with a KEY."
48
   (typecase mac-name
49
     (symbol
50
      (let ((name (massage-symbol mac-name)))
51
        (if (macp name)
52
            (apply (the function (get name '%make-mac)) key args)
53
            (error 'unsupported-mac :name mac-name))))
54
     (t
55
      (error 'type-error :datum mac-name :expected-type 'symbol))))