darcs - smoke

1 (in-package :smoke)

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.

8 (defun id-class-map (smoke)

9 (let ((value (gethash (pointer-address (smoke-module-pointer smoke))

10 *smoke-id-class-map*)))

11 (assert value () "Unknown smoke module ~A." smoke)

12 value))

14 (defun (setf id-class-map) (new-value smoke)

15 (setf (gethash (pointer-address (smoke-module-pointer smoke))

16 *smoke-id-class-map*)

17 new-value))

19 (defun add-id-class-map (smoke)

20 (setf (id-class-map smoke) (make-hash-table)))

22 (defun add-id (smoke-class class)

23 "Associates the CLOS class CLASS with SMOKE-CLASS."

24 (setf (gethash (id smoke-class) (id-class-map (smoke smoke-class)))

25 class))

27 (defun find-smoke-class (class &optional (error-p t))

28 "Returns the CLOS class for smoke-class CLASS."

29 (let* ((class (handler-case (real-class class)

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)))

36 ret))