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

KindCoveredAll%
expression2039 51.3
branch710 70.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/macs/const.lisp --- DEFINE-CONSTANT and friends
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :std/macs)
7
 
8
 ;;; Definitions
9
 (defun %reevaluate-constant (name value test)
10
   (if (not (boundp name))
11
       value
12
       (let ((old (symbol-value name))
13
             (new value))
14
         (if (not (constantp name))
15
             (prog1 new
16
               (cerror "Try to redefine the variable as a constant."
17
                       "~@<~S is an already bound non-constant variable ~
18
                        whose value is ~S.~:@>" name old))
19
             (if (funcall test old new)
20
                 old
21
                 (restart-case
22
                     (error "~@<~S is an already defined constant whose value ~
23
                               ~S is not equal to the provided initial value ~S ~
24
                               under ~S.~:@>" name old new test)
25
                   (ignore ()
26
                     :report "Retain the current value."
27
                     old)
28
                   (continue ()
29
                     :report "Try to redefine the constant."
30
                     new)))))))
31
 
32
 (defmacro define-constant (name initial-value &key (test #'eql) documentation)
33
   "Ensures that the global variable named by NAME is a constant with a value
34
 that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
35
 /function designator/ that defaults to EQL. If DOCUMENTATION is given, it
36
 becomes the documentation string of the constant.
37
 
38
 Signals an error if NAME is already a bound non-constant variable.
39
 
40
 Signals an error if NAME is already a constant variable whose value is not
41
 equal under TEST to result of evaluating INITIAL-VALUE."
42
   `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
43
      ,@(when documentation `(,documentation))))