darcs - qt.core

1 (in-package :cl-smoke.qt.core)

3 (defvar *cxx-lisp-objects* (smoke::make-synchronized-hash-table)

4 "Objects that are currently passed in a C++ class.")

6 (let ((id 0))

7 (declare (type (smoke::c-integer :unsigned-int) id))

8 (defun gen-cxx-lisp-object-id ()

9 "Returns a new unique ID."

10 (loop do

11 (setf id

12 (logand (1- (expt 2 (* 8 (foreign-type-size :unsigned-int) )))

13 (1+ id)))

14 while (nth-value 1 (gethash id *cxx-lisp-objects*)))

15 id))

17 (defcfun cl-smoke-setup-lisp-object :int

18 (destruct :pointer))

20 (defcfun cl-smoke-lisp-object-id :unsigned-int

21 (object :pointer))

23 (defcfun cl-smoke-lisp-object-is-set :int

24 (object :pointer))

26 (defcfun cl-smoke-make-lisp-object :pointer

27 (id :unsigned-int))

29 (defcfun cl-smoke-free-lisp-object :void

30 (object :pointer))

32 (defcallback destruct-cxx-lisp-object :void

33 ((id :unsigned-int))

34 (remhash id *cxx-lisp-objects*))

36 (defvar *cxx-lisp-object-metatype* "Metatype ID of the C++ lisp_object.")

38 (eval-startup ()

39 (setf *cxx-lisp-object-metatype*

40 (cl-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))

41 (assert (>= *cxx-lisp-object-metatype*

42 (smoke::value qt:meta-type.+user+))

43 (*cxx-lisp-object-metatype*)

44 "setup of lisp-object failed"))

46 (defun make-cxx-lisp-object (object)

47 "Constructs a C++ object wrapper for OBJECT."

48 (let ((id (gen-cxx-lisp-object-id)))

49 (setf (gethash id *cxx-lisp-objects*) object)

50 (cl-smoke-make-lisp-object id)))

52 (defun free-cxx-lisp-object (pointer)

53 "Deletes the lisp_object at POINTER."

54 (cl-smoke-free-lisp-object pointer))

55 ;; (qmetatype.destroy *cxx-lisp-object-metatype* pointer)) ;; FIXME use this?

57 (defun translate-cxx-lisp-object (pointer)

58 "Returns the object of the cxx-lisp-object at POINTER.

60 When being received as an argument by a slot,

61 the object must not be deallocated."

62 (multiple-value-bind (value present-p)

63 (gethash (cl-smoke-lisp-object-id pointer)

64 *cxx-lisp-objects*)

65 (assert present-p (value present-p)

66 "No object for ~A in ~A" pointer *cxx-lisp-objects*)

67 value))