repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Fix class-map image loading and use the new static smoke methods.
Annotate for file /src/class-map.lisp
2009-04-05 tobias
1
(in-package :smoke)
15:36:29 '
2
'
3
(defvar *smoke-id-class-map*
'
4
(make-hash-table)
'
5
"Maps a Smoke module pointer - id pair to a class.")
'
6
;; FIXME disallow adding a class when threads are running or add a lock.
'
7
2009-05-14 tobias
8
(defun id-class-map (smoke)
2009-06-22 tobias
9
(let ((value (gethash (pointer-address (smoke-module-pointer smoke))
2009-05-14 tobias
10
*smoke-id-class-map*)))
2010-01-17 tobias
11
(assert value () "Unknown smoke module ~A." smoke)
2009-05-14 tobias
12
value))
12:07:00 '
13
'
14
(defun (setf id-class-map) (new-value smoke)
2009-08-02 tobias
15
(setf (gethash (pointer-address (smoke-module-pointer smoke))
10:12:41 '
16
*smoke-id-class-map*)
2009-05-14 tobias
17
new-value))
2009-04-05 tobias
18
15:36:29 '
19
(defun add-id-class-map (smoke)
2009-08-02 tobias
20
(setf (id-class-map smoke) (make-hash-table)))
2009-04-05 tobias
21
15:36:29 '
22
(defun add-id (smoke-class class)
'
23
"Associates the CLOS class CLASS with SMOKE-CLASS."
2009-08-02 tobias
24
(setf (gethash (id smoke-class) (id-class-map (smoke smoke-class)))
2009-04-05 tobias
25
class))
15:36:29 '
26
2009-08-27 tobias
27
(defun find-smoke-class (class &optional (error-p t))
2009-04-05 tobias
28
"Returns the CLOS class for smoke-class CLASS."
2009-08-27 tobias
29
(let* ((class (handler-case (real-class class)
11:43:13 '
30
(undefined-class (e) (when error-p (error e)))))
'
31
(ret (when class (gethash (id class) (id-class-map (smoke class))))))
'
32
(when error-p
'
33
(assert (not (null ret))
'
34
()
'
35
"The class ~A was not found." (name class)))
2009-04-05 tobias
36
ret))