Sun Jan 10 09:52:49 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Split up in qt.gui & cleanup name prefix.

--- old-qt.gui/src/lisp-object.lisp 2014-10-30 07:42:07.000000000 +0100

+++ new-qt.gui/src/lisp-object.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,67 +0,0 @@

-(in-package :cl-smoke.qt-impl)

-

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

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

-

-(let ((id 0))

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

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

- "Returns a new unique ID."

- (loop do

- (setf id

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

- (1+ id)))

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

- id))

-

-(defcfun qt-smoke-setup-lisp-object :int

- (destruct :pointer))

-

-(defcfun qt-smoke-lisp-object-id :unsigned-int

- (object :pointer))

-

-(defcfun qt-smoke-lisp-object-is-set :int

- (object :pointer))

-

-(defcfun qt-smoke-make-lisp-object :pointer

- (id :unsigned-int))

-

-(defcfun qt-smoke-free-lisp-object :void

- (object :pointer))

-

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

- ((id :unsigned-int))

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

-

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

-

-(eval-startup ()

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

- (qt-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))

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

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

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

- "setup of lisp-object failed"))

-

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

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

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

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

- (qt-smoke-make-lisp-object id)))

-

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

- "Deletes the lisp_object at POINTER."

- (qt-smoke-free-lisp-object pointer))

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

-

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

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

-

-When being received as an argument by a slot,

-the object must not be deallocated."

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

- (gethash (qt-smoke-lisp-object-id pointer)

- *cxx-lisp-objects*)

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

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

- value))