Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/lmj-global-vars-20190319075150/global-vars.lisp

KindCoveredAll%
expression034 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; Copyright (c) 2014 James M. Lawrence
2
 ;;; 
3
 ;;; Permission is hereby granted, free of charge, to any person
4
 ;;; obtaining a copy of this software and associated documentation
5
 ;;; files (the "Software"), to deal in the Software without
6
 ;;; restriction, including without limitation the rights to use, copy,
7
 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
8
 ;;; of the Software, and to permit persons to whom the Software is
9
 ;;; furnished to do so, subject to the following conditions:
10
 ;;; 
11
 ;;; The above copyright notice and this permission notice shall be
12
 ;;; included in all copies or substantial portions of the Software.
13
 ;;; 
14
 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15
 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16
 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17
 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
18
 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
19
 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20
 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
21
 ;;; DEALINGS IN THE SOFTWARE.
22
 
23
 (defpackage #:global-vars
24
   (:export #:define-global-var
25
            #:define-global-var*
26
            #:define-global-parameter
27
            #:define-global-parameter*)
28
   (:use :cl))
29
 
30
 (in-package #:global-vars)
31
 
32
 (setf (documentation 'define-global-var 'function)
33
 "Define a global variable with a compile-time value.
34
 
35
 Subsequent redefinitions will not change the value (like `defvar').
36
 
37
 The `value' argument is evaluated at compile-time. On SBCL, this
38
 permits optimizations based upon the invariant that `name' is always
39
 bound.")
40
 
41
 (setf (documentation 'define-global-var* 'function)
42
 "Same as `define-global-var` except `value` is evaluated at load time,
43
 not compile time.")
44
 
45
 (setf (documentation 'define-global-parameter 'function)
46
 "Same as `define-global-var` except subsequent redefinitions will
47
 update the value (like `defparameter`).")
48
 
49
 (setf (documentation 'define-global-parameter* 'function)
50
 "Same as `define-global-parameter` except `value` is evaluated at load
51
 time, not compile time.")
52
 
53
 ;;; To ensure that a value form is evaluated only once, we store the
54
 ;;; result in the symbol plist of the variable being defined. Another
55
 ;;; reason for this is to preserve the toplevelness of essential
56
 ;;; forms.
57
 
58
 (defmacro store-in-symbol-plist (name value key)
59
   `(progn
60
      (eval-when (:compile-toplevel)
61
        (setf (get ',name ',key) ,value))
62
      (unless (get ',name ',key)
63
        (setf (get ',name ',key) ,value))))
64
 
65
 (defconstant +value-key+ '.value-key.)
66
 
67
 #+sbcl
68
 (progn
69
   (defmacro define-global-var (&whole whole
70
                                name value &optional documentation)
71
     (declare (ignore name value documentation))
72
     `(sb-ext:defglobal ,@(rest whole)))
73
   
74
   (defmacro define-global-var* (&whole whole
75
                                 name value &optional documentation)
76
     (declare (ignore name value documentation))
77
     `(sb-ext:define-load-time-global ,@(rest whole)))
78
 
79
   (defmacro define-global-parameter (name value &optional documentation)
80
     `(progn
81
        (store-in-symbol-plist ,name ,value ,+value-key+)
82
        (sb-ext:defglobal ,name (get ',name +value-key+)
83
          ,@(when documentation (list documentation)))
84
        (eval-when (:compile-toplevel :load-toplevel :execute)
85
          (setf ,name (get ',name +value-key+)))
86
        (remprop ',name +value-key+)
87
        ',name))
88
 
89
   (defmacro define-global-parameter* (name value &optional documentation)
90
     `(progn
91
        (setf (get ',name +value-key+) ,value)
92
        (sb-ext:define-load-time-global ,name (get ',name +value-key+)
93
          ,@(when documentation (list documentation)))
94
        (setf ,name (get ',name +value-key+))
95
        (remprop ',name +value-key+)
96
        ',name)))
97
 
98
 #+(or ccl lispworks)
99
 (progn
100
   (defmacro define-global-var* (&whole whole
101
                                 name value &optional documentation)
102
     (declare (ignore #+lispworks name value documentation))
103
     ;; defstaticvar doesn't return the var name; likely a ccl bug
104
     #+ccl `(progn (ccl:defstaticvar ,@(rest whole)) ',name)
105
     #+lispworks `(hcl:defglobal-variable ,@(rest whole)))
106
 
107
   (defmacro define-global-parameter* (&whole whole
108
                                       name value &optional documentation)
109
     (declare (ignore name value documentation))
110
     #+ccl `(ccl:defstatic ,@(rest whole))
111
     #+lispworks `(hcl:defglobal-parameter ,@(rest whole)))
112
 
113
   (defmacro define-global-var (&whole whole
114
                                name value &optional documentation)
115
     (declare (ignore name value documentation))
116
     `(eval-when (:compile-toplevel :load-toplevel :execute)
117
        (define-global-var* ,@(rest whole))))
118
 
119
   (defmacro define-global-parameter (name value &optional documentation)
120
     `(progn
121
        (store-in-symbol-plist ,name ,value ,+value-key+)
122
        (eval-when (:compile-toplevel :load-toplevel :execute)
123
          (define-global-parameter* ,name (get ',name +value-key+)
124
            ,@(when documentation (list documentation))))
125
        (remprop ',name +value-key+)
126
        ',name)))
127
 
128
 #-(or sbcl ccl lispworks)
129
 (progn
130
   (defmacro define-global-parameter* (name value &optional documentation)
131
     `(progn
132
        (setf (symbol-value ',name) ,value)
133
        (define-symbol-macro ,name (symbol-value ',name))
134
        ,@(when documentation
135
            `((setf (documentation ',name 'variable) ,documentation)))
136
        ',name))
137
 
138
   (defmacro define-global-var* (&whole whole
139
                                   name value &optional documentation)
140
     (declare (ignore value documentation))
141
     `(progn
142
        ;; The symbol macro must be present in any case so compilers
143
        ;; don't complain about undeclared variable references.
144
        (define-symbol-macro ,name (symbol-value ',name))
145
        (unless (boundp ',name)
146
          (define-global-parameter* ,@(rest whole)))
147
        ',name))
148
 
149
   (defmacro define-global-parameter (name value &optional documentation)
150
     `(progn
151
        (store-in-symbol-plist ,name ,value ,+value-key+)
152
        (eval-when (:compile-toplevel :load-toplevel :execute)
153
          (define-global-parameter* ,name (get ',name +value-key+)
154
            ,@(when documentation (list documentation))))
155
        (remprop ',name +value-key+)
156
        ',name))
157
 
158
   (defmacro define-global-var (&whole whole
159
                                  name value &optional documentation)
160
     (declare (ignore name value documentation))
161
     `(eval-when (:compile-toplevel :load-toplevel :execute)
162
        (define-global-var* ,@(rest whole)))))