Thu Jul 2 21:37:42 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix potential lisp-object ID generation overflow for excessive lisp-object creation.

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

+++ new-qt.gui/src/lisp-object.lisp 2014-10-30 07:45:50.000000000 +0100

@@ -4,27 +4,33 @@

"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."

- (incf 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 :int

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

(object :pointer))

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

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

(object :pointer))

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

- (id :int))

+ (id :unsigned-int))

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

(object :pointer))

(defcallback destruct-cxx-lisp-object :void

- ((id :int))

+ ((id :unsigned-int))

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

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