Tue Jul 13 21:17:41 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Use libsmokebase instead of libsmokeqtcore.

-find_library(smokeqtcore_LIB smokeqtcore)

-if (smokeqtcore_LIB)

- set(smokeqtcore_FOUND TRUE)

-endif (smokeqtcore_LIB)

+find_library(smokebase_LIB smokebase)

+if (smokebase_LIB)

+ set(smokebase_FOUND TRUE)

+endif (smokebase_LIB)

-if (smokeqtcore_FOUND)

- message(STATUS "Found smokeqtcore: ${smokeqtcore}")

-else (smokeqtcore_FOUND)

- message(FATAL_ERROR "Could not find smokeqtcore")

-endif (smokeqtcore_FOUND)

+if (smokebase_FOUND)

+ message(STATUS "Found smokebase: ${smokebase}")

+else (smokebase_FOUND)

+ message(FATAL_ERROR "Could not find smokebase")

+endif (smokebase_FOUND)

-target_link_libraries(clsmoke ${QT_LIBRARIES} ${smokeqtcore_LIB})

+target_link_libraries(clsmoke ${QT_LIBRARIES} ${smokebase_LIB})

Sat Apr 3 21:11:26 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* slot-value access for static attributes using the class instead of an object.

+(defmethod slot-missing (meta-class (class smoke-standard-class) slot-name operation &optional new-value)

+ (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))

+ (if (or (not (valid-p method)) (not (static-p method)))

+ (call-next-method)

+ (ecase operation

+ (setf [_$_]

+ (handler-case (funcall (fdefinition

+ (intern

+ (concatenate 'string "SET-"

+ (string-upcase

+ (string slot-name)))

+ :cxx))

+ class new-value)

+ (undefined-function ()

+ (error "The C++ attribute ~A of ~A is read only." slot-name class))

+ (no-applicable-cxx-method (condition)

+ (if (null (viable-functions (condition-method condition)

+ (length (condition-arguments condition))

+ (condition-class condition)))

+ (error "The C++ attribute ~A of ~A is read only." slot-name class)

+ (error condition)))))

+ (slot-boundp t)

+ (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name class))

+ (slot-value (s-call method (null-pointer)))))))

+

- (let ((method (find-smoke-method (class-of object) (lisp-to-cxx (string slot-name)))))

+ (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))

Sat Apr 3 14:04:39 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Make the slot-* functions work for C++ class attributes.

Allow slot-value to be used to access C++ member variables of objects.

- (get-class type))

+ (get-class type))

- (cerror "Remove the old object."

- "The object at pointer ~A is ~A but should be a ~A."

- object (get-object object) type)

- (remove-object object)

+ (when (stack-p type)

+ ;; The first member varible of a class can have the

+ ;; same address as its object.

+ ;; e.g.: QSharedData::ref

+ (cerror "Remove the old object."

+ "The object at pointer ~A is ~A but should be a ~A."

+ object (get-object object) type)

+ (remove-object object))

-

+

+(defmethod slot-missing ((class smoke-standard-class) object slot-name operation &optional new-value)

+ (let ((method (find-smoke-method (class-of object) (lisp-to-cxx (string slot-name)))))

+ (if (not (valid-p method))

+ (call-next-method)

+ (ecase operation

+ (setf [_$_]

+ (handler-case (funcall (fdefinition

+ (intern

+ (concatenate 'string "SET-"

+ (string-upcase

+ (string slot-name)))

+ :cxx))

+ object new-value)

+ (undefined-function ()

+ (error "The C++ attribute ~A of ~A is read only." slot-name object))

+ (no-applicable-cxx-method (condition)

+ (if (null (viable-functions (condition-method condition)

+ (length (condition-arguments condition))

+ (condition-class condition)))

+ (error "The C++ attribute ~A of ~A is read only." slot-name object)

+ (error condition)))))

+ (slot-boundp t)

+ (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name object))

+ (slot-value (s-call method (cast object (get-class method))))))))

Sat Apr 3 14:03:07 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix attribute vs method map to same Lisp name clash.

e.g.: setWidget() and set_widget are in Lisp both #'set-widget. Prefer the method

over the attribute; the attribute will be accessible with SLOT-VALUE.

- (setf (gethash (lispify name "CXX") generics)

- name))

+ (let ((lisp-name (lispify name "CXX")))

+ (unless (and (gethash lisp-name generics) (attribute-p method))

+ (setf (gethash lisp-name generics) name))))

Wed Mar 10 17:38:58 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Improve missing to-lisp-translator error message.

- (cerror "Return the pointer"

- "Do not know how to convert the type ~A to Lisp." type))))

+ (cerror "Return the pointer"

+ "Missing type translator to convert the type ~A to Lisp."

+ type))))

Sat Feb 20 21:56:27 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Allow passing integers as enum arguments.

-(defun coerce-enum (enum)

+(defun coerce-from-enum (enum)

+(defun coerce-to-enum (number)

+ ;; we can skip the enum type because it is not checked at this

+ ;; point.

+ (make-instance 'enum :value number))

+

- (make-match 'promotion 'coerce-enum)))

+ (make-match 'promotion 'coerce-from-enum)))

- (make-match 'promotion 'coerce-enum)))

+ (make-match 'promotion 'coerce-from-enum)))

- (make-match 'promotion 'coerce-double-float)))))

+ (make-match 'promotion 'coerce-double-float)))

+ (12 (when (object.typep '(integer 0))

+ (make-match 'promotion 'coerce-to-enum)))))

Sat Feb 20 19:01:21 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix overload resolution exact match for long and ulong.

- (8 (object.typep '(c-integer :long)))

- (9 (object.typep '(c-integer :unsigned-long)))

+ (8 (object.typep '(and (c-integer :long)

+ (not (c-integer :int)))))

+ (9 (object.typep '(and (c-integer :unsigned-long)

+ (not (c-integer :unsigned-int)))))

Sat Feb 20 18:56:48 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Faster no overload resolution method lookup.

- *m = get_smoke(smoke)->findMethod(class_name, method_name);

+ Smoke::ModuleIndex id_class(get_smoke(smoke), class_index);

+

+ Smoke::ModuleIndex id_method_name = get_smoke(smoke)->findMethodName(class_name, method_name);

+ *m = get_smoke(smoke)->findMethod(id_class, id_method_name);

Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cache overload resolution on sbcl

- (find-best-viable-function (constructor-name class)

- arguments

- class)

+ (#-sbcl find-best-viable-function

+ #+sbcl find-best-viable-function-cached

+ (constructor-name class)

+ arguments

+ class nil)

+ (declare (optimize (speed 3)))

- (foreign-slot-pointer [_$_]

- (mem-aref (smoke-array-pointer

- (smoke-module-types (smoke type)))

- 'smoke-type

- (the smoke-index (id type)))

- 'smoke-type 'name)

- :pointer)))

+ (foreign-slot-pointer [_$_]

+ (mem-aref (smoke-array-pointer

+ (smoke-module-types (smoke type)))

+ 'smoke-type

+ (the smoke-index (id type)))

+ 'smoke-type 'name)

+ :pointer)))

-(eval-when (:compile-toplevel :load-toplevel :execute)

- (defun conversion-function (name &optional arg)

- (if arg

- `(if (using-typep)

- `(,,name

- (find-class ',(class-name ,arg)))

- #'(lambda (object)

- (funcall (fdefinition ,name)

- object ,arg)))

- `(if (using-typep)

- ,name

- (fdefinition ,name)))))

-

- `(,(symbolicate 'make- (eval type))

- :function-name ,(conversion-function name argument)

- ,@args))

+ (flet ((conversion-function (name &optional arg)

+ (if arg

+ `(if (using-typep)

+ `(,,name

+ ,(if (typep ,arg 'class)

+ `(find-class ',(class-name ,arg))

+ `(find-smoke-method (find-class ,(class-name

+ (find-smoke-class

+ (get-class ,arg))))

+ ,(name ,arg))))

+ #'(lambda (object)

+ (funcall (fdefinition ,name)

+ object ,arg)))

+ `(if (using-typep)

+ ,name

+ (fdefinition ,name)))))

+ `(,(symbolicate 'make- (eval type))

+ :function-name ,(conversion-function name argument)

+ ,@args)))

- (subtypep type ',lisp-type)

+ (multiple-value-bind (value valid-p)

+ (subtypep type ',lisp-type)

+ (unless valid-p

+ (throw 'unspecific-type type))

+ value)

- (12 (and (object.typep 'enum) ;; FIXME enum-type using type

- (smoke-type= type (enum-type object))))

+ (12 (when (object.typep 'enum)

+ (when (using-typep)

+ (throw 'unspecific-type object))

+ (smoke-type= type (enum-type object))))

- (find-best-viable-function name

- arguments

- (smoke-class-of object-or-class)

- (when (typep object-or-class

- 'smoke-standard-object)

- (const-p object-or-class)))

+ (#-sbcl find-best-viable-function

+ #+sbcl find-best-viable-function-cached

+ name

+ arguments

+ (smoke-class-of object-or-class)

+ (when (typep object-or-class

+ 'smoke-standard-object)

+ (const-p object-or-class)))

- (if (static-p method)

- (apply #'call-sequence method (null-pointer) sequence arguments)

- (apply #'call-sequence method (cast object-or-class (get-class method)) [_$_]

- sequence arguments))))

+ (apply #'call-sequence method

+ (if (static-p method)

+ (null-pointer)

+ (cast object-or-class (get-class method)))

+ sequence arguments)))

-;;; cache ==================================================================

+;;; Cache overload resolution / method lookup

+

+;;; FIXME the cached lookup should be faster

-;;; we could replace the call to #'find-best-viable-function in

-;;; #'call-using-args with a call to

-;;; #'find-best-viable-function-cached, but it is only doubles speed.

+;;; cache return value conversion

+;;;

+;;; Using the gf symbol instead of the method name would be better,

+;;; althoug we would have to invent one for constructors.

+;;;

+;;; Since the -using-types stuff was intended for for compile time

+;;; expansion it is not that well suited for this. i.e. passing

+;;; closures would be better than the actual syntax.

+;;;

+;;; For qt.tests the uncached calls make up 30 % of all calls.

+;;; qt.examples:colliding-mice (run for ~1 min) gets 20 % uncached

+;;; calls and qt.examples:class-browser get 10 %. (20 February 2010)

-(sb-int:defun-cached (find-best-viable-function-using-types-cached

+(sb-int:defun-cached (find-best-viable-function-using-layouts-cached

- (class class)

+ (sb-c::layout class)

- (sxhash arguments)

+ (the fixnum

+ (reduce [_$_]

+ #'logxor

+ (mapcar #'sb-c::layout-clos-hash

+ arguments)))

- (find-best-viable-function-using-types name arguments class const-p)

+ (find-best-viable-function-using-types

+ name (mapcar #'sb-pcl::wrapper-class* arguments)

+ class const-p)

+ (declare (optimize (speed 3)))

- (second s)))))

+ (eval (second s))))))

- [_$_]

+

- (find-best-viable-function-using-types-cached

+ (find-best-viable-function-using-layouts-cached

- (mapcar #'(lambda (o) (class-of o)) arguments)

+ (mapcar #'(lambda (o) (sb-c::layout-of o)) arguments)

Fri Feb 19 22:22:50 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* cleanup #'delete-object & optimize #'constructor-name.

- (let ((name-start (search "::" (name class) :from-end t)))

+ (declare (optimize (speed 3)))

+ (let* ((name (the simple-string (name class)))

+ (name-start (search "::" name :from-end t)))

- (subseq (name class) (+ name-start 2))

- (name class))))

+ (subseq name (+ name-start 2))

+ name)))

- (let ((method-name (concatenate 'string "~" (name (class-of object)))))

- (s-call

- (make-smoke-method-from-name (class-of object) method-name)

- (pointer object)))

+ (delete-pointer (pointer object) (class-of object))

Fri Feb 19 22:10:24 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* No need to construct a SmokeBinding per Smoke module.

-

- (binding (null-pointer) :type foreign-pointer)

- (no-dispatch-binding (null-pointer) :type foreign-pointer)

- ((binding :pointer)

- (method smoke-index)

+ ((method smoke-index)

- :smoke (gethash (pointer-address

- (smoke-get-smoke binding))

- *smoke-modules*)

+ :smoke (smoke (class-of object))

-/** Returns the Smoke module of a Smoke binding.

- * @related cl_smoke::Binding

- * @param binding the Binding

- *

- * @return the Smoke module

- */

-CL_SMOKE_EXPORT void*

-cl_smoke_get_smoke(smoke_binding binding)

-{

- return static_cast<NoDispatchBinding*>(binding)->get_smoke();

-}

-

-cl_smoke_construct_binding(void* smoke, void* destruct, void* dispatch)

+cl_smoke_construct_binding(void* destruct, void* dispatch)

- return new NoDispatchBinding(static_cast<Smoke*>(smoke),

- reinterpret_cast<NoDispatchBinding::destructed>(destruct));

+ return new NoDispatchBinding(reinterpret_cast<NoDispatchBinding::destructed>(destruct));

- return new Binding(static_cast<Smoke*>(smoke),

- reinterpret_cast<NoDispatchBinding::destructed>(destruct),

+ return new Binding(reinterpret_cast<NoDispatchBinding::destructed>(destruct),

- * @param smoke the smoke binding

+ * @param smoke the smoke module

- (smoke :pointer)

-(declaim (inline smoke-get-smoke))

-(defcfun (smoke-get-smoke "cl_smoke_get_smoke") :pointer

- (smoke-binding smoke-binding))

-

- * @param smoke the Smoke module

-NoDispatchBinding::NoDispatchBinding(Smoke *smoke, destructed destruct)

- : SmokeBinding(smoke),

+NoDispatchBinding::NoDispatchBinding(destructed destruct)

+ : SmokeBinding(NULL),

- Q_ASSERT(classId >= 0 && classId <= smoke->numClasses);

- return const_cast<char*>(smoke->classes[classId].className);

+ qFatal("className() Not implemented");

- * @param smoke the Smoke module

-Binding::Binding(Smoke *smoke, destructed destruct,

- dispatch_method dispatch)

- : NoDispatchBinding(smoke, destruct),

+Binding::Binding(destructed destruct, dispatch_method dispatch)

+ : NoDispatchBinding(destruct),

- int ret = dispatch(this, method, object, stack, abstract);

+ int ret = dispatch(method, object, stack, abstract);

- NoDispatchBinding(Smoke *smoke, destructed destruct);

+ NoDispatchBinding(destructed destruct);

- Smoke*

- get_smoke() const

- { return smoke; }

-

- typedef int (*dispatch_method)(Binding* binding, Smoke::Index method,

+ typedef int (*dispatch_method)(Smoke::Index method,

- Binding(Smoke *smoke, destructed destruct, dispatch_method dispatch);

+ Binding(destructed destruct, dispatch_method dispatch);

+(eval-startup (:load-toplevel :execute)

+ (defparameter *binding* (smoke-construct-binding

+ (callback destructed)

+ (callback dispatch-method)))

+ (defparameter *no-dispatch-binding* (smoke-construct-binding

+ (callback destructed)

+ (null-pointer))))

+

- (smoke-module-binding (smoke class))

- (smoke-module-no-dispatch-binding (smoke class))))

+ *binding*

+ *no-dispatch-binding*))

- (let ((no-dispatch-binding

- (smoke-construct-binding smoke (callback destructed) (null-pointer)))

- (binding (smoke-construct-binding smoke (callback destructed)

- (callback dispatch-method))))

- (setf (smoke-module-pointer module) smoke

- (smoke-module-no-dispatch-binding module) no-dispatch-binding

- (smoke-module-binding module) binding)

- (init-smoke-module module)

- (setf (gethash (pointer-address smoke) *smoke-modules*) module)

- module))

+ (setf (smoke-module-pointer module) smoke)

+ (init-smoke-module module)

+ (setf (gethash (pointer-address smoke) *smoke-modules*) module)

+ module)

Thu Feb 18 20:57:00 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Don't dispatch virtual methods for builtin classes (reduces overhead).

+ (no-dispatch-binding (null-pointer) :type foreign-pointer)

- (when (and object (typep (class-of object) 'cxx:class))

- ;; Do not allow overwriting methods of classes the users has

- ;; not derived from (like in C++), to reduce overhead.

+ (unless (null object)

-/** Casts the void pointer smoke_binding to the Binding class.

- * @param smoke the smoke binding

- *

- * @return pointer to the Binding instance

- */

-static inline

-Binding*

-get_smoke_binding(smoke_binding binding)

-{

- return static_cast<Binding*>(binding);

-}

-

+ (:namespace #x08)

+(declaim (inline smoke-class-id))

- return get_smoke_binding(binding)->get_smoke();

+ return static_cast<NoDispatchBinding*>(binding)->get_smoke();

+ * When method dispatching is not needed, a null pointer can be passed for @a dispatch.

+ * @related cl_smoke::NoDispatchBinding

+ * @related cl_smoke_destruct_binding

-cl_smoke_init(void* smoke, void* destruct, void* dispatch)

+cl_smoke_construct_binding(void* smoke, void* destruct, void* dispatch)

- return new Binding(static_cast<Smoke*>(smoke),

- reinterpret_cast<Binding::destructed>(destruct),

- reinterpret_cast<Binding::dispatch_method>(dispatch));

+ if (NULL == dispatch)

+ return new NoDispatchBinding(static_cast<Smoke*>(smoke),

+ reinterpret_cast<NoDispatchBinding::destructed>(destruct));

+ else

+ return new Binding(static_cast<Smoke*>(smoke),

+ reinterpret_cast<NoDispatchBinding::destructed>(destruct),

+ reinterpret_cast<Binding::dispatch_method>(dispatch));

-/** Deletes the smoke binding.

- * @related cl_smoke::Binding

+/** Deletes the Smoke binding.

+ * @related cl_smoke_construct_binding

-cl_smoke_destruct(smoke_binding binding)

+cl_smoke_destruct_binding(smoke_binding binding)

- delete get_smoke_binding(binding)->get_smoke();

- delete get_smoke_binding(binding);

+ // Destructor is virtual; thus we can do this.

+ delete static_cast<SmokeBinding*>(binding);

-/** Gets a Smoke modules name.

+/** Gets a Smoke module name.

- *m = get_smoke(smoke)->findMethod(get_smoke(smoke)->className(class_index),

- method_name);

+ Q_ASSERT(class_index >= 0 && class_index <= get_smoke(smoke)->numClasses);

+

+ const char* class_name = get_smoke(smoke)->className(class_index);

+ *m = get_smoke(smoke)->findMethod(class_name, method_name);

+

- * @param object the objec

+ * @param object the object

-(defcfun (smoke-init "cl_smoke_init") smoke-binding

+(defcfun (smoke-construct-binding "cl_smoke_construct_binding") smoke-binding

-(defcfun (smoke-destruct "cl_smoke_destruct") :void

+(defcfun (smoke-destruct-destruct "cl_smoke_destruct_binding") :void

-/** @class Binding

- * @brief The Smoke binding.

+/** @class NoDispatchBinding

+ * @brief The Smoke binding for classes we need no dispatching.

+ * This saves some overhead, since it does not call into Lisp.

+ * Idea stolen from CommonQt ;)

+ *

+ * Dispatches for non extended classes (not of class CXX:CLASS) are between

+ * 20% - 40% (for qt.examples:colliding-mice - qt.examples:class-browser). (18 February 2010)

-

-/** @typedef Binding::destructed

+/** @typedef NoDispatchBinding::destructed

+/** Constructor.

+ * @param smoke the Smoke module

+ * @param destruct destruct callback

+ */

+NoDispatchBinding::NoDispatchBinding(Smoke *smoke, destructed destruct)

+ : SmokeBinding(smoke),

+ destruct(destruct)

+{

+ Q_ASSERT(destruct);

+}

+

+/** Invoked when a Smoke object is destructed. */

+void

+NoDispatchBinding::deleted(Smoke::Index, void *object)

+{

+ destruct(object);

+}

+

+/** Invoked when a Smoke method gets called. */

+bool

+NoDispatchBinding::callMethod(Smoke::Index method, void* object,

+ Smoke::Stack stack, bool abstract)

+{

+ Q_ASSERT(!abstract);

+ return false;

+}

+

+/**

+ * @todo Returning a const char* would be better

+ */

+char*

+NoDispatchBinding::className(Smoke::Index classId)

+{

+ Q_ASSERT(classId >= 0 && classId <= smoke->numClasses);

+ return const_cast<char*>(smoke->classes[classId].className);

+}

+

+/** @function NoDispatchBinding::get_smoke()

+ * Gets the Smoke instance associated with the binding.

+ * @return a pointer to the Smoke instance

+ */

+

+/** @class Binding

+ * @brief The Smoke binding.

+ */

- : SmokeBinding(smoke),

- destruct(destruct),

+ : NoDispatchBinding(smoke, destruct),

- Q_ASSERT(smoke);

- Q_ASSERT(destruct);

-/** Invoked when a Smoke object is destructed. */

-void

-Binding::deleted(Smoke::Index, void *object)

-{

- destruct(object);

-}

-/**

- * @todo Returning a const char* would be better

- */

-char*

-Binding::className(Smoke::Index classId)

-{

- return const_cast<char*>(smoke->classes[classId].className);

-}

-

-/** Gets the Smoke instance associated with the binding.

- * @return a pointer to the Smoke instance

- */

-Smoke*

-Binding::get_smoke() const

-{

- return smoke;

-}

-

-class Binding : public SmokeBinding

+class NoDispatchBinding : public SmokeBinding

- typedef int (*dispatch_method)(Binding* binding, Smoke::Index method,

- void* object, Smoke::Stack args, int abstract);

-

- Binding(Smoke *smoke, destructed destruct, dispatch_method dispatch);

+ NoDispatchBinding(Smoke *smoke, destructed destruct);

- get_smoke() const;

+ get_smoke() const

+ { return smoke; }

+};

+

+class Binding : public NoDispatchBinding

+{

+ public:

+ typedef int (*dispatch_method)(Binding* binding, Smoke::Index method,

+ void* object, Smoke::Stack args, int abstract);

+

+ Binding(Smoke *smoke, destructed destruct, dispatch_method dispatch);

+

+

+ virtual bool

+ callMethod(Smoke::Index method, void* object,

+ Smoke::Stack stack, bool abstract);

+

+

+ private:

- (with-foreign-object (stack 'smoke-stack-item 2)

- (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1)

- 'smoke-stack-item 'voidp)

- (smoke-module-binding (smoke (class-of object))))

- (foreign-funcall-pointer [_$_]

- (foreign-slot-value (smoke-class-pointer (class-of object))

- 'smoke-class 'class-function)

- ()

- smoke-index 0 ;; set binding method index

- :pointer (pointer object)

- smoke-stack stack

- :void)))

+ (let ((class (class-of object)))

+ (with-foreign-object (stack 'smoke-stack-item 2)

+ (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1)

+ 'smoke-stack-item 'voidp)

+ (if (typep class 'cxx:class)

+ (smoke-module-binding (smoke class))

+ (smoke-module-no-dispatch-binding (smoke class))))

+ (foreign-funcall-pointer [_$_]

+ (foreign-slot-value (smoke-class-pointer class)

+ 'smoke-class 'class-function)

+ ()

+ smoke-index 0 ;; set binding method index

+ :pointer (pointer object)

+ smoke-stack stack

+ :void))))

- (let* ((binding (smoke-init smoke (callback destructed)

- (callback dispatch-method))))

+ (let ((no-dispatch-binding

+ (smoke-construct-binding smoke (callback destructed) (null-pointer)))

+ (binding (smoke-construct-binding smoke (callback destructed)

+ (callback dispatch-method))))

+ (smoke-module-no-dispatch-binding module) no-dispatch-binding

Thu Feb 18 19:31:47 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix casting across Smoke modules.

- (id (class-of object)) (id class)))

+ (id (class-of object))

+ (smoke-class-id (smoke-module-pointer (smoke (class-of object)))

+ (name-pointer class))))

+(defun name-pointer (class)

+ (mem-ref (foreign-slot-pointer (smoke-class-pointer class)

+ 'smoke-class 'name)

+ :pointer))

+

Wed Feb 17 18:05:35 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Remove underlinking of libclsmoke and add a darwin case to the library definitons.

Thanks to Elliott Slaughter

+

+# FIXME look for smoke.h

+find_library(smokeqtcore_LIB smokeqtcore)

+if (smokeqtcore_LIB)

+ set(smokeqtcore_FOUND TRUE)

+endif (smokeqtcore_LIB)

+

+if (smokeqtcore_FOUND)

+ message(STATUS "Found smokeqtcore: ${smokeqtcore}")

+else (smokeqtcore_FOUND)

+ message(FATAL_ERROR "Could not find smokeqtcore")

+endif (smokeqtcore_FOUND)

+

+

+target_link_libraries(clsmoke ${QT_LIBRARIES} ${smokeqtcore_LIB})

-install(TARGETS clsmoke clsmokeutil

- LIBRARY DESTINATION lib)

+install(TARGETS clsmoke clsmokeutil DESTINATION lib)

-;; Load the qt smoke binding to prevent undefined aliens.

- (define-foreign-library libsmokeqtcore

- (:unix "libsmokeqtcore.so.3")

- (t (:default "libsmokeqtcore")))

+ (:darwin "libclsmoke.dylib")

+ (:darwin "libclsmokeutil.dylib")

- (use-foreign-library libsmokeqtcore)

-

+ (:darwin ,(format nil "~(~A~).3.dylib" library))

Tue Feb 16 22:56:19 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Load libsmokeqtcore instead of qt in the default case of cffi:define-foreign-library.

- (define-foreign-library libsmokeqt

+ (define-foreign-library libsmokeqtcore

- (t (:default "libsmokeqt")))

+ (t (:default "libsmokeqtcore")))

- (use-foreign-library libsmokeqt)

+ (use-foreign-library libsmokeqtcore)

Tue Feb 16 22:52:02 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix derived-p for classes that are external in every module.

- (handler-case (make-smoke-class (name class))

- (undefined-class () class))

+ (make-smoke-class (name class))

-;(defun smoke-subclassp (class base-class) TODO

- (values

- (derived-real-p (real-class class) (real-class base-class))

- T))

+ (handler-case (derived-real-p (real-class class) (real-class base-class))

+ ;; The class is external in every module => no derived.

+ (undefined-class () nil)))

Mon Feb 15 16:31:33 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Build a shared library not a module.

Fixes on build error on OS X as reported by Elliott Slaughter.

-add_library(clsmoke MODULE ${SMOKE_C_SOURCES})

+add_library(clsmoke SHARED ${SMOKE_C_SOURCES})

-add_library(clsmokeutil MODULE smoke_util.cpp)

+add_library(clsmokeutil SHARED smoke_util.cpp)

Mon Feb 8 18:14:54 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* sbcl-bundle requires posix & unix

- #+sbcl :sb-posix)

+ #+(and sbcl unix) :sb-posix)

- #+sbcl (:file "sbcl-bundle")

+ #+(and sbcl unix) (:file "sbcl-bundle")

Thu Feb 4 16:11:29 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Test building libclsmoke.

+cmake ./ || exit 1

+make || exit 1

Wed Feb 3 17:20:56 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix compiling libclsmoke with asserts enabled.

smoke_get_class was not declared in this scope

Reported by:

Elliott Slaughter

- Q_ASSERT(!smoke_get_class(smoke, class_index)->external);

- Q_ASSERT(!smoke_get_class(smoke_base, base_index)->external);

+ Q_ASSERT(!cl_smoke_get_class(smoke, class_index)->external);

+ Q_ASSERT(!cl_smoke_get_class(smoke_base, base_index)->external);

Wed Feb 3 07:44:09 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Add missing :sb-posix dependency.

- (:cffi :closer-mop :alexandria :trivial-garbage :bordeaux-threads)

+ (:cffi :closer-mop :alexandria :trivial-garbage :bordeaux-threads

+ #+sbcl :sb-posix)

Sat Jan 30 15:40:08 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Do not warn on missing parent class.

- (if real-class

- (push (class-name real-class) class-symbols)

- (warn "The class ~A could not be found in any module."

- (name class))))

+ (when real-class

+ (push (class-name real-class) class-symbols)))

Tue Jan 26 17:26:09 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix for r1077826. Not instantiable parent classes are external. (QAbstractPrintDialog)

-(defun smoke-class-symbol (smoke-class)

- "Returns the Lisp class-name of SMOKE-CLASS:"

- (if (external-p smoke-class)

- (class-name (find-smoke-class smoke-class))

- (lispify (name smoke-class))))

+(defun smoke-class-symbols (classes)

+ (let ((class-symbols))

+ (dolist (class classes class-symbols)

+ (if (external-p class)

+ (let ((real-class (find-smoke-class class nil)))

+ (if real-class

+ (push (class-name real-class) class-symbols)

+ (warn "The class ~A could not be found in any module."

+ (name class))))

+ (push (lispify (name class)) class-symbols)))))

- (mapcar #'smoke-class-symbol

- (smoke-class-direct-superclasses class))

+ (smoke-class-symbols

+ (smoke-class-direct-superclasses class))

Mon Jan 25 19:47:00 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Check enum type on overload resolution

- (12 (object.typep 'enum)) ;; FIXME enum-type

+ (12 (and (object.typep 'enum) ;; FIXME enum-type using type

+ (smoke-type= type (enum-type object))))

Mon Jan 25 19:46:41 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* single-float conversion

+(defun coerce-single-float (number)

+ (float number 0f0))

+

+ (10 (when (object.typep 'real)

+ (make-match 'promotion 'coerce-single-float)))

Mon Jan 25 19:41:22 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Add :arg3 for make-instance SMOKE-CLASS.

+ (arg3 nil arg3p)

+ (arg3p (list arg0 arg1 arg2 arg3))

Sat Jan 23 20:45:41 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* class & type size (and some more exports)

+(defun class-size (smoke-class)

+ (class-slot-value smoke-class 'size))

+

+(defun copy-constructor-p (class)

+ (/= 0 (get-class-flag class :copy-constructor)))

+

- (error "Do not know how to convert the type ~A to Lisp." type)))

+ (prog1 (foreign-slot-value stack-item 'smoke-stack-item 'voidp)

+ (cerror "Return the pointer"

+ "Do not know how to convert the type ~A to Lisp." type))))

+;; Return the cffi keyword for the type

+(defun type-foreign-keyword (smoke-type)

+ (intern (nsubstitute #\- #\ (nstring-upcase (name smoke-type)))

+ :keyword))

+

+(defun type-size (smoke-type)

+ (if (class-p smoke-type)

+ (class-size (get-class smoke-type))

+ (foreign-type-size (type-foreign-keyword smoke-type))))

+

- (:export #:init

- #:get-smoke-variable-for-pointer

+ (:export #:call

+ #:c-integer

- #:make-smoke-classes

- #:eval-startup

- [_$_]

- #:delete-object

- #:smoke-call

- #:call

-

- #:name

+ #:class-p

+ #:class-size

+ #:const-p

- #:smoke-type=

+ #:name

+ #:pointer

+ #:pointer-p

+ #:size

+ #:smoke

+ #:stack-p

+ #:type-foreign-keyword

+ #:type-id

+ #:type-size

+ #:virtual-destructor-p

+ #:convert-argument

+ #:*to-lisp-translations*

+

- #:make-cleanup-pointer

+ #:define-smoke-module

+

+ #:define-takes-ownership

+ #:delete-object

+ #:remove-object

+

+ #:eval-startup

+

+ #:get-smoke-variable-for-pointer

+ #:init

+ #:object-to-lisp

+

+ #:make-cleanup-pointer

- #:const-p

- #:pointer

- #:define-smoke-module

- #:define-takes-ownership

+ #:make-smoke-classes

+ #:make-smoke-type

+ #:no-applicable-cxx-method

+ #:smoke-call

+ #:upcast

+

+ #:smoke-standard-object

+ #:smoke-type

+ #:smoke-type=

- ;; FIXME when loading the Lisp image we no longer need to

- ;; call #'ensure-class, but the class-map needs still

+ ;; FIXME when loading the Lisp image we no longer need

+ ;; to call #'ensure-class, but the class-map needs still

Sun Jan 17 22:04:08 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix class-map image loading and use the new static smoke methods.

indClass() and isDerivedFrom() are now static (r1076132 and also in KDE 4.4).

- (assert value ()

- "Unknown smoke module ~A ~A."

- smoke (smoke-get-module-name (smoke-module-pointer smoke)))

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

- (smoke :pointer)

- * @param smoke the smoke module

-cl_smoke_find_class(Smoke::ModuleIndex* c, void* smoke, const char* name)

+cl_smoke_find_class(Smoke::ModuleIndex* c, const char* name)

- *c = get_smoke(smoke)->findClass(name);

+ *c = Smoke::findClass(name);

- return get_smoke(smoke)->isDerivedFrom(get_smoke(smoke), class_index,

+ return Smoke::isDerivedFrom(get_smoke(smoke), class_index,

- ((smoke-name :initarg :smoke-name

- :initform nil

- :documentation "The name of the Smoke module"))

+ ()

- (format stream "No Smoke class named ~S in the Smoke module ~S."

- (cell-error-name condition)

- (slot-value condition 'smoke-name))))

+ (format stream "No Smoke class named ~S."

+ (cell-error-name condition))))

-(defun make-smoke-class (smoke name)

- "Returns the class named NAME of the smoke module SMOKE.

+(defun make-smoke-class (name)

+ "Returns the class named NAME.

- (smoke-find-class c (smoke-module-pointer smoke) name)

+ (smoke-find-class c name)

- (error (make-condition 'undefined-class :name name :smoke-name (smoke-get-module-name (smoke-module-pointer smoke))))

+ (error (make-condition 'undefined-class :name name))

- (handler-case (make-smoke-class (smoke class) (name class))

+ (handler-case (make-smoke-class (name class))

- (call-next-method)

+ (print-unreadable-object (smoke-method stream :type t)

+ (princ "no method" stream))

- (format nil "~A~:[~; static~]" (access method) (static-p method)))

+ (format nil "~:[~;virtual ~]~A~:[~; static~]" [_$_]

+ (virtual-p method) (access method) (static-p method)))

+(defun virtual-p (method)

+ "Returns T when METHOD is internal and NIL otherwise."

+ (/= 0 (get-method-flag method :virtual)))

+

+ (eval-startup (:compile-toplevel :load-toplevel :execute)

+ ;; FIXME when loading the Lisp image we no longer need to

+ ;; call #'ensure-class, but the class-map needs still

+ ;; to be populated by #'add-id-class-map and #'add-id;

+ ;; For now we ignore the negligible overhead.

+ (make-smoke-classes ,package ,smoke))

- (make-smoke-classes ,package ,smoke)

-(defun static-call (smoke class-name method-name &rest args)

- (s-call (make-smoke-method-from-name (make-smoke-class smoke class-name)

- method-name)

- (null-pointer) args))

-

Sun Jan 10 18:31:42 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix overload resolution when a lisp smoke module is not loaded.

-(defmethod operation-done-p ((o test-op) (c (eql (find-system :cl-smoke.smoke))))

- nil)

-

+(define-condition lisp-module-not-loaded (error)

+ ((class-name :initarg :class-name))

+ (:report (lambda (condition stream)

+ (format stream "The Lisp smoke module of the class ~A is not loaded."

+ (slot-value condition 'class-name)))))

+

- (make-instance 'smoke-class

- :id (foreign-slot-value c 'smoke-module-index 'index)

- :smoke (gethash (pointer-address (foreign-slot-value c 'smoke-module-index 'smoke)) *smoke-modules*))))

+ (let ((class (make-instance

+ 'smoke-class

+ :id (foreign-slot-value c 'smoke-module-index 'index)

+ :smoke (gethash (pointer-address (foreign-slot-value

+ c 'smoke-module-index

+ 'smoke))

+ *smoke-modules*))))

+ (unless (smoke class)

+ (error (make-condition 'lisp-module-not-loaded :class-name name)))

+ class)))

- (let ((to-class (find-smoke-class (get-class type) nil)))

- (when (and to-class

- (call-using-types find-best-viable-function2

- (if (using-typep)

- #'standard-conversion-sequence-using-types

- #'standard-conversion-sequence)

- (constructor-name (get-class type))

- (list object) to-class))

- (make-match 'user-conversion

- 'coerce-to-class

- to-class)))))

+ (handler-case

+ (let ((to-class (find-smoke-class (get-class type) nil)))

+ (when (and to-class

+ (call-using-types find-best-viable-function2

+ (if (using-typep)

+ #'standard-conversion-sequence-using-types

+ #'standard-conversion-sequence)

+ (constructor-name (get-class type))

+ (list object) to-class))

+ (make-match 'user-conversion

+ 'coerce-to-class

+ to-class)))

+ ;; When the correspoinding Lisp module is not loaded, we ignore

+ ;; the overload.

+ (lisp-module-not-loaded ()))))

Sun Jan 10 18:30:48 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Auto-recompile when the smoke module has changed.

- "Raises an error when the fasl of the DEFINE-METHOS was not compiled against

-the current smoke module."

- `(eval-when (:load-toplevel :execute)

- (unless (sizes= (,smoke)

- smoke-module-methods

- smoke-module-method-names

- smoke-module-method-maps

- smoke-module-classes

- smoke-module-types)

- (error "The smoke module ~A changed, you need to recompile the lisp file."

- (smoke-get-module-name (smoke-module-pointer ,smoke))))))

+ "Raises an error or tries to recompile when the fasl of the define-classes-and-gfs

+was not compiled against the current smoke module."

+ (with-unique-names (restart)

+ `(eval-when (:load-toplevel :execute)

+ (unless (sizes= (,smoke)

+ smoke-module-methods

+ smoke-module-method-names

+ smoke-module-method-maps

+ smoke-module-classes

+ smoke-module-types)

+ (let ((,restart (find-restart 'asdf:try-recompiling)))

+ (if ,restart

+ (invoke-restart ,restart)

+ (error "The smoke module ~A changed, you need to recompile the lisp file."

+ (smoke-get-module-name (smoke-module-pointer ,smoke)))))))))

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

* Support modular smoke & cleanup.

-(defpackage smoke-system

- (:use :cl :asdf))

-

-(in-package smoke-system)

-

-(asdf:defsystem :smoke

- :name :smoke

+(defsystem :cl-smoke.smoke

+ :name :cl-smoke.smoke

- (:file "smoke" :depends-on (:smoke-c :objects "clos"))

+ (:file "smoke" :depends-on (:libsmoke :objects "clos"))

- (:file "bindings" :depends-on ("package"))

+ (:file "bindings" :depends-on ("package" :utils))

- (:file "clos" :depends-on

- (:smoke-c "cxx-method" :objects "object-map" "class-map" "bindings"))

+ (:file "clos" :depends-on (:libsmoke "cxx-method" :objects

+ "object-map" "class-map" "bindings"))

- :depends-on (:smoke-c :utils "bindings")

+ :depends-on (:libsmoke :utils "bindings")

- (:module :smoke-c

+ (:module :libsmoke

- ((:file "smoke-c") (:file "class" :depends-on ("smoke-c"))

+ ((:file "smoke")

+ (:file "class" :depends-on ("smoke"))

-(defmethod asdf:perform ((operation test-op) (c (eql (find-system :smoke))))

- (operate 'asdf:load-op :qt)

- (operate 'asdf:test-op :qt))

+(defmethod operation-done-p ((o test-op) (c (eql (find-system :cl-smoke.smoke))))

+ nil)

+

+(defmethod perform ((operation test-op) (c (eql (find-system :cl-smoke.smoke))))

+ (operate 'asdf:load-op :cl-smoke.qt.tests)

+ (operate 'asdf:test-op :cl-smoke.qt.tests))

-add_subdirectory(smoke-c)

+add_subdirectory(libsmoke)

-(defvar *bindings* (make-hash-table)

- "The Smoke C++ binding classes to which virtual method calls are dispatched.")

-

-;; FIXME is this lock needed? (The user may not have to

-;; load additional modules while threads are running.

-(defvar *bindings-lock* (make-lock "bindings-lock"))

-

-(defun binding (smoke)

- "Returns the Smoke binding for the Smoke module SMOKE."

- (with-lock-held (*bindings-lock*)

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

- (gethash (pointer-address smoke) *bindings*)

- (assert (eql t present-p)

- ()

- "No binding for ~A." smoke)

- value)))

-

-(defun (setf binding) (binding smoke)

- (with-lock-held (*bindings-lock*)

- (setf (gethash (pointer-address smoke) *bindings*)

- binding)))

-

+(eval-on-save ()

+ (clrhash *smoke-modules*))

+

- (let ((*package* (find-package package)))

+ (let ((impl-package *package*)

+ (*package* (find-package package)))

- (unless (or (external-p class)

- (and (eq package :cl-smoke.qt)

- (string/= (smoke-get-module-name [_$_]

- (smoke-module-pointer smoke))

- "qt")

- (string= (name class) "QGlobalSpace")))

+ (unless (external-p class)

- (add-id class

- (closer-mop:ensure-class (lispify (name class))

- :direct-superclasses

- (mapcar #'smoke-class-symbol

- (smoke-class-direct-superclasses class))

- :id (id class)

- :smoke (smoke class)

- :metaclass 'smoke-standard-class))

- (export (lispify (name class))))))

+ (let ((class-name [_$_]

+ ;; There is a QGlobalSpace class per Smoke module.

+ ;; Put it in *package* and not PACKAGE to avoid

+ ;; clashes between multiple modules.

+ (if (string= "QGlobalSpace" (name class))

+ (lispify "QGlobalSpace" impl-package)

+ (lispify (name class)))))

+ (add-id class

+ (closer-mop:ensure-class class-name

+ :direct-superclasses

+ (mapcar #'smoke-class-symbol

+ (smoke-class-direct-superclasses class))

+ :id (id class)

+ :smoke (smoke class)

+ :metaclass 'smoke-standard-class))

+ (when (eql (symbol-package class-name) *package*)

+ (export class-name))))))

-set(SMOKE_C_SOURCES smoke-c.cpp csmokebinding.cpp)

-add_library(smoke-c MODULE ${SMOKE_C_SOURCES})

-set_target_properties(smoke-c

+set(SMOKE_C_SOURCES smoke.cpp smokebinding.cpp)

+add_library(clsmoke MODULE ${SMOKE_C_SOURCES})

+set_target_properties(clsmoke

-add_library(smoke-c-util MODULE smoke-c-util.cpp)

-set_target_properties(smoke-c-util

+add_library(clsmokeutil MODULE smoke_util.cpp)

+set_target_properties(clsmokeutil

-install(TARGETS smoke-c smoke-c-util

+install(TARGETS clsmoke clsmokeutil

-/** @brief Common Lisp Smoke binding namespace. */

+/** @brief cl-smoke binding namespace. */

-(defcfun smoke-find-class :void

+(defcfun (smoke-find-class "cl_smoke_find_class") :void

-(defcfun smoke-class-id smoke-index

+(defcfun (smoke-class-id "cl_smoke_class_id") smoke-index

-(defcfun smoke-get-class (:pointer smoke-class)

+(defcfun (smoke-get-class "cl_smoke_get_class") (:pointer smoke-class)

-(defcfun smoke-is-derived-from :boolean

+(defcfun (smoke-is-derived-from "cl_smoke_is_derived_from") :boolean

-(defcfun smoke-cast :pointer

+(defcfun (smoke-cast "cl_smoke_cast") :pointer

-(defcfun smoke-find-method :void

+(defcfun (smoke-find-method "cl_smoke_find_method") :void

-#include "csmokebinding.h"

+#include "smokebinding.h"

-

-smoke_get_smoke(smoke_binding binding)

+cl_smoke_get_smoke(smoke_binding binding)

-smoke_init(void* smoke, void* destruct, void* dispatch)

+cl_smoke_init(void* smoke, void* destruct, void* dispatch)

-smoke_destruct(smoke_binding binding)

+cl_smoke_destruct(smoke_binding binding)

-smoke_get_module_name(void* smoke)

+cl_smoke_get_module_name(void* smoke)

-smoke_find_class(Smoke::ModuleIndex* c, void* smoke, const char* name)

+cl_smoke_find_class(Smoke::ModuleIndex* c, void* smoke, const char* name)

-smoke_class_id(void* smoke, const char* name)

+cl_smoke_class_id(void* smoke, const char* name)

-smoke_get_class(void* smoke, Smoke::Index class_index)

+cl_smoke_get_class(void* smoke, Smoke::Index class_index)

-smoke_is_derived_from(void* smoke, Smoke::Index class_index, void* smoke_base, Smoke::Index base_index)

+cl_smoke_is_derived_from(void* smoke, Smoke::Index class_index, void* smoke_base,

+ Smoke::Index base_index)

- get_smoke(smoke_base), base_index);

+ get_smoke(smoke_base), base_index);

-smoke_find_method(Smoke::ModuleIndex* m, void* smoke,

+cl_smoke_find_method(Smoke::ModuleIndex* m, void* smoke,

-smoke_find_type(void* smoke, const char* name)

+cl_smoke_find_type(void* smoke, const char* name)

-smoke_cast(void* smoke, void* object, Smoke::Index from, Smoke::Index to)

+cl_smoke_cast(void* smoke, void* object, Smoke::Index from, Smoke::Index to)

- (:unix "libsmokeqt.so.3")

+ (:unix "libsmokeqtcore.so.3")

- (define-foreign-library libsmoke-c

- (:unix "libsmoke-c.so")

- (t (:default "libsmoke-c")))

- (define-foreign-library libsmoke-c-util

- (:unix "libsmoke-c-util.so")

- (t (:default "libsmoke-c-util")))

+ (define-foreign-library libclsmoke

+ (:unix "libclsmoke.so")

+ (t (:default "libclsmoke")))

+ (define-foreign-library libclsmokeutil

+ (:unix "libclsmokeutil.so")

+ (t (:default "libclsmokeutil")))

- (use-foreign-library libsmoke-c))

+ (use-foreign-library libclsmoke))

- (use-foreign-library libsmoke-c-util)

- (defcfun smoke-sizeof-bool :int)

+ (use-foreign-library libclsmokeutil)

+ (defcfun (smoke-sizeof-bool "cl_smoke_sizeof_bool") :int)

- (load-foreign-library 'libsmoke-c-util)

+ (load-foreign-library 'libclsmokeutil)

-;(close-foreign-library 'libsmoke-c-util)

+;(close-foreign-library 'libclsmokeutil)

-(defcfun smoke-init smoke-binding

+(defcfun (smoke-init "cl_smoke_init") smoke-binding

-(defcfun smoke-destruct :void

+(defcfun (smoke-destruct "cl_smoke_destruct") :void

-(defcfun smoke-get-smoke :pointer

+(defcfun (smoke-get-smoke "cl_smoke_get_smoke") :pointer

-(defcfun smoke-get-module-name :string

+(defcfun (smoke-get-module-name "cl_smoke_get_module_name") :string

-smoke_sizeof_bool()

+cl_smoke_sizeof_bool()

-#include "csmokebinding.h"

+#include "smokebinding.h"

-#ifndef CSMOKEBINDING_H

-#define CSMOKEBINDING_H

+#ifndef SMOKEBINDING_H

+#define SMOKEBINDING_H

-#endif // CSMOKEBINDING_H

+#endif // SMOKEBINDING_H

-(defcfun smoke-find-type smoke-index

+(defcfun (smoke-find-type "cl_smoke_find_type") smoke-index

+ (tg:gc :full t) ;; Try to get all #'smoke::make-auto-pointer

- (warn "life object ~A" object)

+ (warn "life object ~A ~A" object (pointer object))

- `(define-constant ,symbol ;; a long not really an enum.

+ `(define-constant ,symbol ;; a long, not really an enum.

- (call-using-args (find-class (quote ,(lispify (name class) package)))

- ,method-name

- ,(if (< argument-count 0)

- 'args

- `(list ,@(make-lambda argument-count)))))

+ (call-using-args

+ (find-class (quote ,(lispify (name class) [_$_]

+ (if (string= (name class)

+ "QGlobalSpace")

+ *package* ;; See #'MAKE-SMOKE-CLASSES

+ package))))

+ ,method-name

+ ,(if (< argument-count 0)

+ 'args

+ `(list ,@(make-lambda argument-count)))))

- (when (enum-p method)

+ (when (and (enum-p method)

+ ;; qt.network has QIODevice::NotOpen(), but the

+ ;; class is external (workaround).

+ (not (external-p (get-class method))))

- (setf (gethash function-symbol function-symbols)

- (if methods (- (id method)) (id method)))))))

+ (unless (fboundp function-symbol) ;; do not overwrite

+ ;; existing functions e.g. qInstallMsgHandler of

+ ;; qt.core with that of qt.gui which causes a

+ ;; segfault when loading from an saved image.

+ (setf (gethash function-symbol function-symbols)

+ (if methods (- (id method)) (id method))))))))

- (eval-startup (:load-toplevel :execute)

- ;; eval on startup for class map.

- (make-smoke-classes ,package ,smoke))

+ (make-smoke-classes ,package ,smoke)

-;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

+;;; Copyright (C) 2009, 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

- (use-foreign-library libsmoke-c)

+ (use-foreign-library libclsmoke)

- (setf (binding smoke) binding

- (smoke-module-pointer module) smoke

+ (setf (smoke-module-pointer module) smoke

+ ;; Used by make-load-form for enums to reference the smoke module.

- ;;FIXME speed this up, needed by (mb:document :smoke).

-MALLOC_CHECK_=3 sbcl --eval '(require :qt.tests)' \

+MALLOC_CHECK_=3 sbcl --eval '(require :cl-smoke.qt.tests)' \

-sh ./test-bundle.sh || exit 2

+ sh ./test-bundle.sh || exit 2

-(asdf:operate 'asdf:load-op :smoke)

-(asdf:operate 'asdf:test-op :smoke)

+(require :asdf)

+(asdf:operate 'asdf:load-op :cl-smoke.smoke)

+(asdf:operate 'asdf:test-op :cl-smoke.smoke)

Sun Dec 13 13:43:58 CET 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Support ASDF instead of Mudballs.

+(defpackage smoke-system

+ (:use :cl :asdf))

+

+(in-package smoke-system)

+

+(asdf:defsystem :smoke

+ :name :smoke

+ :version (0 0 1)

+ :author "Tobias Rautenkranz"

+ :license "GPL with linking exception"

+ :description "Smoke bindings. Provides the base functionality to

+implement bindings using the various Smoke modules."

+ :depends-on

+ (:cffi :closer-mop :alexandria :trivial-garbage :bordeaux-threads)

+

+ :components

+ ((:module :src :components

+ ((:file "package")

+ (:file "using-type" :depends-on ("package"))

+ (:file "overload-resolution" :depends-on ("package" "smoke" "using-type"))

+ #+sbcl (:file "sb-optimize" :depends-on ("overload-resolution"))

+ (:file "smoke" :depends-on (:smoke-c :objects "clos"))

+ (:file "object-map" :depends-on (:objects :utils))

+ (:file "class-map" :depends-on ("package"))

+ (:file "bindings" :depends-on ("package"))

+ (:file "cxx-method" :depends-on ("package"))

+ (:file "clos" :depends-on

+ (:smoke-c "cxx-method" :objects "object-map" "class-map" "bindings"))

+ (:file "smoke-to-clos" :depends-on ("clos" "overload-resolution"))

+ (:module :objects

+ :serial t

+ :depends-on (:smoke-c :utils "bindings")

+ :components

+ ((:file "object") (:file "enum" :depends-on ("object"))

+ (:file "type" :depends-on ("enum"))

+ (:file "method" :depends-on ("type"))

+ (:file "class" :depends-on ("method"))

+ (:file "instance" :depends-on ("class"))

+ (:file "stack" :depends-on ("instance"))))

+ (:module :smoke-c

+ :depends-on ("package")

+ :components

+ ((:file "smoke-c") (:file "class" :depends-on ("smoke-c"))

+ (:file "stack" :depends-on ("class"))

+ (:file "method" :depends-on ("stack"))

+ (:file "type" :depends-on ("method"))))

+ (:module :utils

+ :depends-on ("package")

+ :components

+ ((:file "get-value")

+ #+sbcl (:file "sbcl-bundle")

+ (:module :image :components

+ ((:file "image" :depends-on (:impl))

+ (:module :impl

+ :components

+ (#+sbcl (:file "sbcl")

+ #+openmcl (:file "ccl")

+ #+(not (or sbcl openmcl))

+ (:file "not-implemented")))))))))))

+

+(defmethod asdf:perform ((operation test-op) (c (eql (find-system :smoke))))

+ (operate 'asdf:load-op :qt)

+ (operate 'asdf:test-op :qt))

-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-

-

-;;; Allow this file to compile even when sysdef.cmake is not loaded.

-;;; You can not add a (MB:LOAD :SYSDEF.CMAKE) on top since when Mudballs

-;;; loads this file it might not know yet about :SYSDEF.CMAKE.

-(defpackage :sysdef.cmake

- (:use :cl :sysdef)

- (:export :cmake-file :cmake-library))

-(in-package :sysdef.cmake)

-

-(defclass sysdef.cmake:cmake-file (source-file)

- ()

- (:default-initargs :type "txt"))

-

-(defclass sysdef.cmake:cmake-library (component)

- ((package :initarg :package)))

-;;; end SYDDEF.CMAKE

-

-(in-package :sysdef-user)

-(eval-when (:compile-toplevel :load-toplevel :execute)

- (use-package :sysdef.cmake))

-

-(define-system :smoke ()

- (:version 0 0 1)

- (:documentation "Smoke bindings. Provides the base functionality to

-implement bindings using the various Smoke modules.")

- (:author "Tobias Rautenkranz")

- (:license "GPL with linking exception")

- (:components

- ("CMakeLists" cmake-file)

- (:src module

- (:needs "CMakeLists")

- (:components

- "package"

- ("using-type" (:needs "package"))

- ("overload-resolution" (:needs "package" "smoke" "using-type"))

- ("sb-optimize" (:for :sbcl) (:needs "overload-resolution"))

- ("smoke" (:needs "smoke-c" "objects" "clos"))

- ("object-map" (:needs "objects" :utils))

- ("class-map" (:needs "package"))

- ("bindings" (:needs "package"))

- ("cxx-method" (:needs "package"))

- ("clos" (:needs "smoke-c" "cxx-method" "objects" "object-map" "class-map" "bindings"))

- ("smoke-to-clos" (:needs "clos" "overload-resolution"))

- (:objects module

- (:needs "smoke-c" "utils" "bindings")

- (:serial t)

- (:components "object" "enum" "type" "method" "class"

- "instance" "stack"))

- (:smoke-c module

- (:needs "package")

- (:components ("libsmoke-c" cmake-library)

- ("libsmoke-c-util" cmake-library)

-

- ("smoke-c" (:needs "libsmoke-c"

- "libsmoke-c-util"))

- ("class" (:needs "smoke-c"))

- ("stack" (:needs "class"))

- ("method" (:needs "stack"))

- ("type" (:needs "method"))))

-

- (:utils module

- (:needs "package")

- (:requires (:sb-posix (:for :sbcl)))

- (:components

- "get-value"

- ("sbcl-bundle" (:for :sbcl))

- (:image module

- (:components [_$_]

- ("image" (:needs "impl"))

- (:impl module

- (:components

- ("sbcl" (:for :sbcl))

- ("ccl" (:for :openmcl))

- ("not-implemented" (:for (:not

- (:or :sbcl :openmcl)))))))))))))

- (:needs :sysdef.cmake :cffi :closer-mop

- :alexandria :trivial-garbage :bordeaux-threads))

- #-mudballs

- #-mudballs

-MALLOC_CHECK_=3 sbcl --eval '(mb:load :qt.tests)' \

+MALLOC_CHECK_=3 sbcl --eval '(require :qt.tests)' \

-# do not use --script to allow loading mudballs with ${HOME}/.sbclrc

-

-(in-package :sysdef-user)

-

-(defun load-sysdef (pathname system)

- (load pathname)

- (setf (mb.sysdef::pathname-of (find-system system)) pathname))

-

-(defun load-sysdef-file (system-name)

- "Loads a mbd file in the current directory."

- (load-sysdef (make-pathname :defaults *default-pathname-defaults*

- :name (string-downcase system-name)

- :type "mbd")

- system-name))

-

-(load-sysdef-file :smoke)

-;(mb:load :FiveAm)

-;(setf 5am:*debug-on-failure* t)

-;(setf 5am:*debug-on-error* t)

-(mb:test :smoke)

+(asdf:operate 'asdf:load-op :smoke)

+(asdf:operate 'asdf:test-op :smoke)

Sun Dec 13 11:17:08 CET 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Update to the new Smoke ABI (v.3)

+(defun attribute-p (method)

+ "Returns T when METHOD accesses C++ member/static variables."

+ (/= 0 (get-method-flag method :attribute)))

+

+(defun property-p (method)

+ "Returns T when METHOD accesses a Q_PROPERTY."

+ (/= 0 (get-method-flag method :property)))

+

- (flags :unsigned-short))

+ (flags :unsigned-short)

+ (size :unsigned-int))

- (:protected #x80))

+ (:protected #x80)

+ (:attribute #x100)

+ (:property #x200)

+ (:virtual #x400)

+ (:purevirtual #x800)

+ (:signal #x1000)

+ (:slot #x2000))

- (flags :unsigned-char)

+ (flags :unsigned-short)

- (:unix "libsmokeqt.so.2")

+ (:unix "libsmokeqt.so.3")

+;; Smoke::ModuleIndex is a POD-struct.

+;; Thus we can treat it as a C struct.

- (:unix ,(format nil "~(~A~).so.2.0" library))

+ (:unix ,(format nil "~(~A~).so.3" library))

- (defcfun (,init-function ,(format nil "_Z~A~Av"

- (length function-name)

- function-name)

- :library ,library)

+ (defcfun (,init-function ,function-name :library ,library)

-sbcl --eval '(mb:load :qt.tests)' \

+MALLOC_CHECK_=3 sbcl --eval '(mb:load :qt.tests)' \

-echo "(progn (5am:run!) (quit))" | ./qt.test.run [_$_]

+echo "(progn (in-package :qt.tests) (5am:run!) (quit))" | MALLOC_CHECK_=3 ./qt.test.run [_$_]

Fri Nov 6 20:27:56 CET 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Explicitly use old ABI (pre r1045709)

- (:unix ,(format nil "~(~A~).so.2" library))

+ (:unix ,(format nil "~(~A~).so.2.0" library))

Wed Sep 9 21:25:37 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Template types are no longer t_class.

- ((0 13) (if-let ((translation (gethash (name type) *to-lisp-translations*)))

- (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

- 'voidp)))

- (prog1 (funcall (car translation) pointer)

- (when (stack-p type)

- (funcall (cdr translation) pointer))))

- (error "Do not know how to convert the type ~A to Lisp." type)))

+ (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))

+ (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

+ 'voidp)))

+ (prog1 (funcall (car translation) pointer)

+ (when (stack-p type)

+ (funcall (cdr translation) pointer))))

+ (error "Do not know how to convert the type ~A to Lisp." type)))

- (13 (if (class-p type)

- (and (object.typep 'smoke-standard-object)

- (smoke-type= (get-class type) (object.type-of)))

- (when-let (test (gethash (name type) *from-lisp-translations*))

- (funcall test object (using-typep)))))))

+ (13 (and (object.typep 'smoke-standard-object)

+ (smoke-type= (get-class type) (object.type-of))))))

Wed Sep 9 15:22:32 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Smoke::t_class is now also used for classes not wrapped by Smoke & remove global-space part from enum symbols.

- (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))

- (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

- 'voidp)))

- (prog1 (funcall (car translation) pointer)

- (when (stack-p type)

- (funcall (cdr translation) pointer))))

- (error "Do not know how to convert the type ~A to Lisp." type)))

+ ((0 13) (if-let ((translation (gethash (name type) *to-lisp-translations*)))

+ (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

+ 'voidp)))

+ (prog1 (funcall (car translation) pointer)

+ (when (stack-p type)

+ (funcall (cdr translation) pointer))))

+ (error "Do not know how to convert the type ~A to Lisp." type)))

- (/= -1 (type-slot-value type 'class))))

+ (not (zerop (type-slot-value type 'class)))))

- (13 (and (object.typep 'smoke-standard-object)

- (smoke-type= (get-class type) (object.type-of))))))

+ (13 (if (class-p type)

+ (and (object.typep 'smoke-standard-object)

+ (smoke-type= (get-class type) (object.type-of)))

+ (when-let (test (gethash (name type) *from-lisp-translations*))

+ (funcall test object (using-typep)))))))

- (declare (optimize (speed 3)))

+ (declare (optimize (speed 3))

+ (type (or smoke-standard-class smoke-standard-object)

+ object-or-class))

- (if (string= (name (get-class method))

- "Qt")

+ (if (or (string= (name (get-class method))

+ "Qt")

+ (string= (name (get-class method))

+ "QGlobalSpace"))

Wed Sep 2 13:49:34 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Various fixes:

* Allow user conversions for return values

* fix destruction of objects with multiple C++ superclasses

* Fix list to QList conversion dispatch

+ (when (typep object 'smoke-multi-superclass-mixin)

+ (dolist (extra-object (extra-objects object))

+ (unless (null-pointer-p (pointer extra-object))

+ (remove-object (pointer extra-object))

+ (delete-object extra-object))))

-(defun convert-argument (argument type &optional (user t))

- "Returns ARGUMENT converted to TYPE. If USER is true, user defined

-conversion sequences are considered."

- (let ((rank (get-conversion-sequence argument type user)))

- (if (null rank)

- (error "Can not convert the argument ~S to ~A."

- argument (name type))

- (funcall (conversion-function-name rank)

- argument))))

+(defun convert-argument (argument type &optional disown)

+ "Returns ARGUMENT converted to TYPE and removes the ownership when

+it is passed on the stack."

+ (flet ((disown (object)

+ (remove-finalizer object)

+ (when (typep object 'smoke-standard-object)

+ (remove-object (pointer object)))))

+ (let ((rank (get-conversion-sequence argument type nil)))

+ (if (null rank)

+ (let ((rank (get-conversion-sequence argument type t)))

+ (if (null rank)

+ (error "Can not convert the argument ~S to ~A."

+ argument (name type))

+ (let ((ret (funcall (conversion-function-name rank)

+ argument)))

+ (when (and disown (stack-p type))

+ (disown ret))

+ ret)))

+ (prog1 (funcall (conversion-function-name rank) argument)

+ (when (and disown (stack-p type))

+ (disown argument)))))))

- ;; FIXME support user conversions.

- ;;

- ;; We need to determine which of value and converted-value is

- ;; passed on the stack. E.g. converted-value can be something

- ;; like (cxx:operator-variant value).

- (let ((converted-value (convert-argument value type nil)))

- (push-smoke-stack stack converted-value (type-id type))

- (when (stack-p type) ;; Pass by value => smoke deletes the object.

- (remove-finalizer converted-value)

- (when (typep value 'smoke-standard-object)

- (remove-object (pointer value))))))))

- ; (transfer-ownership-to value object)))))))

+ (let ((converted-value (convert-argument value type t)))

+ (push-smoke-stack stack converted-value (type-id type))))))

- (assert (not (has-pointer-p (pointer object))) ()

- "There exists already a object ~A for the pointer of ~A."

- (get-object (pointer object)) object)

+ (when (has-pointer-p (pointer object))

+ (cerror "Overwrite the old object."

+ "There exists already a object ~A for the pointer of ~A."

+ (get-object (pointer object)) object))

- #'(lambda (type)

- (and (subtypep type ',lisp-type)

+ #'(lambda (type type-p)

+ (and (if type-p

+ (subtypep type ',lisp-type)

+ (typep type ',lisp-type))

- (funcall test (object.type-of))))

+ (funcall test object (using-typep))))

Tue Sep 1 13:44:21 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix overload resolution using types and test caching the overload resolution.

- (function-name nil :type (or symbol function) :read-only t)

+ (function-name nil :type (or symbol list function) :read-only t)

-(defmacro make-match (type &optional (name ''identity)

- (argument nil)

+(defmacro make-match (type &optional (name ''identity) (argument nil)

- :function-name ,(conversion-function name argument)

- ,@args))

+ :function-name ,(conversion-function name argument)

+ ,@args))

- [_$_]

+

+

+

+;;; cache ==================================================================

+;;;

+;;; we could replace the call to #'find-best-viable-function in

+;;; #'call-using-args with a call to

+;;; #'find-best-viable-function-cached, but it is only doubles speed.

+

+(sb-int:defun-cached (find-best-viable-function-using-types-cached

+ :hash-function (lambda (name arguments

+ class const-p)

+ (declare (string name)

+ (list arguments)

+ (class class)

+ (boolean const-p))

+ (logand [_$_]

+ (logxor

+ (sxhash name)

+ (sxhash arguments)

+ (sxhash class)

+ (sxhash const-p))

+ #x1FF))

+ :hash-bits 9)

+ ((name equal) (arguments equal) (class eq) (const-p eq))

+ (declare (optimize (speed 3))

+ (inline find-best-viable-function-using-types))

+ (multiple-value-bind (method conversion-sequence)

+ (find-best-viable-function-using-types name arguments class const-p)

+ (list method (mapcar #'(lambda (s)

+ (if (symbolp s)

+ (fdefinition s)

+ #'(lambda (x)

+ (funcall (fdefinition (first s))

+ x

+ (second s)))))

+ conversion-sequence))))

+ [_$_]

+(declaim (inline find-best-viable-function-cached))

+(defun find-best-viable-function-cached (name arguments class const-p)

+ (declare (optimize (speed 3)))

+ (catch 'unspecific-type

+ (return-from find-best-viable-function-cached

+ (values-list

+ (find-best-viable-function-using-types-cached

+ name

+ (mapcar #'(lambda (o) (class-of o)) arguments)

+ class

+ const-p))))

+ (find-best-viable-function name arguments class const-p))

+

- ,@body))

+ ,@body))

Sun Aug 30 16:12:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Allow deriving from multiple C++ classes.

+(defclass smoke-multi-superclass-mixin ()

+ ((extra-objects :reader extra-objects

+ :initarg :extra-objects)))

+

- &allow-other-keys)

+ direct-default-initargs &allow-other-keys)

- "No superclass sup-lied for class ~A" class)

- (let ((superclass (first direct-superclasses)))

- (assert (subtypep (class-of superclass) (find-class 'smoke-standard-class))

+ "No superclass supplied for class ~A" class)

+ (let ((superclass (first direct-superclasses))

+ (extra-superclasses (remove-if-not #'(lambda (class)

+ (typep class 'smoke-standard-class))

+ (rest direct-superclasses))))

+ (assert (typep superclass 'smoke-standard-class)

- "The first superclass must be an subclass of an smoke class.")

+ "The first superclass ~A must be an subclass of an Smoke class."

+ class)

- "The class ~A has a non virtual destructor." superclass)

+ "The superclass ~A of ~A has a non virtual destructor."

+ superclass class)

+ (when extra-superclasses

+ (dolist (superclass extra-superclasses)

+ (unless (virtual-destructor-p superclass)

+ (cerror "Continue anyway"

+ "The superclass ~A of ~A has a non virtual destructor."

+ superclass class)))

+ (setf direct-superclasses

+ (append direct-superclasses

+ (list (find-class 'smoke-multi-superclass-mixin))))

+ (push `(:extra-objects ,extra-superclasses ,#'(lambda ()

+ extra-superclasses))

+ direct-default-initargs))

+ :direct-default-initargs direct-default-initargs

-

-;; Receive virutal function calls.

+;; Receive virtual function calls.

-(defun cast (object class)

- "Returns a pointer of type CLASS to the C++ object of OBJECT."

+(defgeneric cast (object class)

- (assert (derived-p (class-of object) class)

- ()

- "Can not cast object ~A of class ~A to class ~A."

- object (name (class-of object)) (name class))

- (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)

- (id (class-of object)) (id class)))

-

+ (:documentation "Returns a pointer of type CLASS to the C++ object of OBJECT.")

+ (:method (object class)

+ (declare (optimize (speed 3)))

+ (assert (derived-p (class-of object) class)

+ ()

+ "Can not cast object ~A of class ~A to class ~A."

+ object (name (class-of object)) (name class))

+ (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)

+ (id (class-of object)) (id class)))

+ (:method ((object smoke-multi-superclass-mixin) class)

+ (if (derived-p (class-of object) class)

+ (call-next-method)

+ (let ((extra-object (find-if #'(lambda (o)

+ (derived-p (class-of o) class))

+ (extra-objects object))))

+ (assert extra-object

+ ()

+ "Can not cast object ~A to class ~A."

+ object (name class))

+ (cast extra-object class)))))

-(defun call-constructor (object arguments)

- (if (null arguments)

- (let ((method (find-smoke-method (class-of object)

- (constructor-name (class-of object)))))

- (assert (valid-p method)

- (method)

- "No constructor for ~A." object)

- (pointer-call method (null-pointer)))

- (multiple-value-bind (method sequence)

- (find-best-viable-function (constructor-name (class-of object))

- arguments

- (class-of object))

- (when (null method)

- (error "No constructor for object ~A with

-the arguments ~S." object arguments))

- (pointer-call method (null-pointer)

- (mapcar #'(lambda (conversion argument)

- (funcall conversion argument))

- sequence arguments)))))

+(defun call-constructor (class arguments)

+ (multiple-value-bind (method sequence)

+ (find-best-viable-function (constructor-name class)

+ arguments

+ class)

+ (when (null method)

+ (error "No constructor for class ~A with

+the arguments ~S." class arguments))

+ (pointer-call method (null-pointer)

+ (mapcar #'(lambda (conversion argument)

+ (funcall conversion argument))

+ sequence arguments))))

- (call-constructor object [_$_]

+ (call-constructor (class-of object)

- (setf (slot-value object 'pointer) (call-constructor object args)))

+ (setf (slot-value object 'pointer)

+ (call-constructor (class-of object) args)))

+(defun construct-extra-objects (object extra-objects)

+ (loop for class in extra-objects

+ collect (let ((extra-object (make-instance (first extra-objects)

+ :pointer (call-constructor (first extra-objects)

+ nil))))

+ (set-binding extra-object)

+ (setf (get-object (pointer extra-object)) object)

+ extra-object)))

+ [_$_]

+(defmethod initialize-instance :after ((object smoke-multi-superclass-mixin) [_$_]

+ &key args)

+ (setf (slot-value object 'extra-objects)

+ (construct-extra-objects object (extra-objects object))))

+

+(defmethod make-finalize ((object smoke-multi-superclass-mixin))

+ (let ((pointer (pointer object))

+ (extra-objects (extra-objects object))

+ (class (class-of object)))

+ #'(lambda ()

+ (declare (optimize (speed 3)))

+ (handler-case (progn

+ (delete-pointer pointer class)

+ (dolist (object extra-objects)

+ (delete-object object)))

+ (error (condition)

+ (report-finalize-error condition 't (name class) pointer))))))

- (cerror "ignore" "~A has already been added to ~A."

+ (cerror "Ignore" "~A has already been added to ~A."

+ ;; #'remove-object is called in the destructed callback. This

+ ;; happens even for objects without an virtual destructor.

-(defun all-smoke-superclasses (class)

- "Returns a list of all super-classes of CLASS and CLASS itself."

- (declare (optimize (speed 3)))

- (let ((classes (list class)))

- (dolist (class (closer-mop:class-direct-superclasses class) classes)

- (when (typep class 'smoke-standard-class)

- (setf classes (append (all-smoke-superclasses class) classes))))))

- [_$_]

+echo \

+"################

+## Testing sbcl

+################"

+echo \

+"###############

+## Testing sbcl image

+################"

+echo \

+"###############

+## Testing ccl [_$_]

+################"

Sun Aug 30 15:51:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Make integer constants return an integer instead of an enum (e,g.: qt:graphics-item.+user-type+).

- package)

+ package)

- package))))

+ package))))

- `(define-constant ,symbol

- (make-instance 'enum

- :value ,(enum-call method)

- :type (make-instance 'smoke-type

- :id ,(id (return-type method))

- :smoke ,smoke))

- :test #'enum=)

+ (if (= 8 (type-id (return-type method)))

+ `(define-constant ,symbol ;; a long not really an enum.

+ ,(enum-call method))

+ `(define-constant ,symbol

+ (make-instance 'enum

+ :value ,(enum-call method)

+ :type (make-instance 'smoke-type

+ :id ,(id (return-type method))

+ :smoke ,smoke))

+ :test #'enum=))

Thu Aug 27 13:43:13 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Support the new smokegenerator (r1015073).

* support const correctness

* remove workarounds for the old smoke

The old smoke is no longer supported.

Thanks to Arno Rehn for making the smokegenerator work with cl-smoke.

+(defmethod print-object ((smoke-module smoke-module) stream)

+ (if (null-pointer-p (smoke-module-pointer smoke-module))

+ (call-next-method)

+ (print-unreadable-object (smoke-module stream :type t :identity t)

+ (princ (smoke-get-module-name (smoke-module-pointer smoke-module))

+ stream))))

+

-(defun find-smoke-class (class)

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

- (let* ((class (real-class class))

- (ret (gethash (id class) (id-class-map (smoke class)))))

- (assert (not (null ret))

- ()

- "The class ~A was not found." (name class))

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

+ (undefined-class (e) (when error-p (error e)))))

+ (ret (when class (gethash (id class) (id-class-map (smoke class))))))

+ (when error-p

+ (assert (not (null ret))

+ ()

+ "The class ~A was not found." (name class)))

+ (when (const-p object)

+ (princ "CONST " stream))

- (unless (external-p class)

- (add-id class

- (closer-mop:ensure-class (lispify (name class))

- :direct-superclasses

- (mapcar #'smoke-class-symbol

- (smoke-class-direct-superclasses class))

- :id (id class)

- :smoke (smoke class)

- :metaclass 'smoke-standard-class))

- (export (lispify (name class)))))

+ (unless (or (external-p class)

+ (and (eq package :cl-smoke.qt)

+ (string/= (smoke-get-module-name [_$_]

+ (smoke-module-pointer smoke))

+ "qt")

+ (string= (name class) "QGlobalSpace")))

+ (with-simple-restart (skip "Skip generating class ~A" (name class)) [_$_]

+ (add-id class

+ (closer-mop:ensure-class (lispify (name class))

+ :direct-superclasses

+ (mapcar #'smoke-class-symbol

+ (smoke-class-direct-superclasses class))

+ :id (id class)

+ :smoke (smoke class)

+ :metaclass 'smoke-standard-class))

+ (export (lispify (name class))))))

- (push (argument-to-lisp (mem-ref stack 'smoke-stack-item)

+ (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item)

- (let ((ret (make-instance class :pointer pointer)))

+ (let ((ret (make-instance class :pointer pointer

+ :const-p (const-p type))))

- (make-smoke-class (smoke class) (name class))

+ (handler-case (make-smoke-class (smoke class) (name class))

+ (undefined-class () class))

- (let ((type (enum-type (eval (first (first cases))))))

+ (flet ((first-key (keys)

+ (if (listp keys)

+ (first keys)

+ keys)))

+ (let ((type (enum-type (eval (first-key (first (first cases)))))))

- (check-enum-type (eval (first case))

+ (check-enum-type (eval (first-key (first case)))

- ; (check-enum-type (enum-type ,keyform)

- ; (enum-type ,(first (first cases))))

+ ;; (check-enum-type (enum-type ,keyform)

+ ;; (enum-type ,(first (first cases))))

- collect `(,(value (eval (first case)))

- ,@(rest case))))))

+ collect `(,(if (listp (first case))

+ (mapcar #'(lambda (c)

+ (print c)

+ (value (eval c)))

+ (first case))

+ (value (eval (first case))))

+ ,@(rest case)))))))

- [_$_]

+ (const-p :reader const-p

+ :initarg :const-p

+ :initform nil

+ :documentation "Returns true when the object is const and nil otherwise.")

+(defvar *to-lisp-translations* (make-hash-table :test 'equal))

+

-(defvar *to-lisp-translations* (make-hash-table :test 'equal))

- (and t ;(pointer-eq (smoke type1)

- ; (smoke type2))

- (= (id type1)

- (id type2))))

+ (if (eq (smoke type1) (smoke type2))

+ (= (id type1) (id type2))

+ (string= (name type1) (name type2))))

- (declare (optimize (speed 3)))

- (zerop (mem-ref (mem-aref (smoke-array-pointer

- (smoke-module-types (smoke type)))

- 'smoke-type

- (the smoke-index (id type)))

- :char)))

+ (null-pointer-p (mem-ref

+ (foreign-slot-pointer [_$_]

+ (mem-aref (smoke-array-pointer

+ (smoke-module-types (smoke type)))

+ 'smoke-type

+ (the smoke-index (id type)))

+ 'smoke-type 'name)

+ :pointer)))

+;;;

+;;; We handle only the most common cases. Stuff like virtual inheritance

+;;; that is not needed is not implemented.

-(defmacro push-candidate-method (index name argument-count class methods)

+(defmacro push-candidate-method (index name argument-count class methods

+ const-p)

- (incf ,ambig-index)

- (push (make-smoke-method :smoke ,smoke

- :id ,i)

- ,methods)))

- (push ,method ,methods))) [_$_]

+ (incf ,ambig-index)

+ (let ((,method (make-smoke-method :smoke ,smoke

+ :id ,i)))

+ (unless (and ,const-p (not (const-p ,method)))

+ (push ,method ,methods)))))

+ (unless (and ,const-p (not (const-p ,method)))

+ (push ,method ,methods))))

-(defun viable-functions (name argument-count class)

- "Returns a list of methods named NAME that take ARGUMENT-COUNT methods."

- ;; 13.3.2

- ;;

- ;; FIXME make a lazy map-viable-functions to allow returning early,

- ;; when an exact match is found.

+(defun viable-functions (name argument-count class &optional const-p)

- (dolist (class (all-smoke-superclasses class))

- (let ((smoke (smoke class)))

- (let ((start-index (find-method-for-class name class)))

- (declare (type smoke-index start-index))

- (when (>= start-index 0)

- (loop for index from start-index downto 1

- while (push-candidate-method index name argument-count class

- methods))

- (loop for index from (1+ start-index)

- to (the smoke-index (smoke-array-length

- (smoke-module-method-maps smoke)))

- while (push-candidate-method index name argument-count class

- methods))))))

+ (let ((smoke (smoke class)))

+ (let ((start-index (find-method-for-class name class)))

+ (declare (type smoke-index start-index))

+ (when (>= start-index 0)

+ (loop for index from start-index downto 1

+ while (push-candidate-method index name argument-count class

+ methods const-p))

+ (loop for index from (1+ start-index)

+ to (the smoke-index (smoke-array-length

+ (smoke-module-method-maps smoke)))

+ while (push-candidate-method index name argument-count class

+ methods const-p)))))

-(defgeneric conversion< (conversion1 conversion2)

- (:documentation

- "Returns true when CONVERSION1 is better than CONVERSION2.")

+(defgeneric conversion<= (conversion1 conversion2)

- (or (null conversion2)

- (< (the fixnum (conversion-rank conversion1))

- (the fixnum (conversion-rank conversion2)))))

+ (and (not (null conversion1))

+ (or (null conversion2)

+ (<= (the fixnum (conversion-rank conversion1))

+ (the fixnum (conversion-rank conversion2))))))

- (:documentation

- "Returns true when the standard conversion sequence CONVERSION1

- is indistinguishable from CONVERSION2.")

- (= (conversion-rank conversion1) (conversion-rank conversion2)))

+ (and (conversion<= conversion1 conversion2)

+ (conversion<= conversion2 conversion1)))

- (if (conversion< conversion1 conversion2)

+ (if (conversion<= conversion1 conversion2)

- (let ((max-rank)

- (conversions))

- (loop for type in (arguments method)

- for class in classes do

- (let ((rank (call-using-type get-conversion-sequence class type user)))

- (when (null rank)

- (setf max-rank nil)

- (return nil))

- (setf max-rank (max-conversion rank max-rank))

- (push (conversion-function-name rank) conversions)))

- (values max-rank (reverse conversions))))

+ (if (null classes)

+ (values (make-match 'exact-match) nil)

+ (let ((max-rank)

+ (conversions))

+ (loop for type in (arguments method)

+ for class in classes do

+ (let ((rank (call-using-type get-conversion-sequence class type user)))

+ (when (null rank)

+ (setf max-rank nil)

+ (return nil))

+ (setf max-rank (max-conversion rank max-rank))

+ (push (conversion-function-name rank) conversions)))

+ (values max-rank (reverse conversions)))))

-(defun+using-types find-best-viable-function (name arguments class)

+(defun+using-types find-best-viable-function (name arguments class

+ &optional const-p)

- name arguments class))

+ name arguments class const-p))

-(defun+using-types find-best-viable-function2 (get-sequence name objects class)

- (declare (type (function (t list) (values t function)) get-sequence))

+(defun+using-types find-best-viable-function2 (get-sequence name objects class

+ &optional const-p)

- class))

+ class const-p))

- (loop for method in viable-functions do

- (multiple-value-bind (rank method-conversions)

- (funcall get-sequence method objects)

- ;; FIXME test for ambiguous overload #'conversion=

- (when (and rank (conversion< rank best-rank))

- (setf best-rank rank)

- (setf best-method method)

- (setf conversions method-conversions)

- (when (conversion= rank (make-match 'exact-match))

- (return)))))

- (values best-method conversions)))

+ (if (null viable-functions)

+ (dolist (class (closer-mop:class-direct-superclasses class)

+ (values best-method nil))

+ (when (typep class 'smoke-standard-class)

+ (multiple-value-bind (method conversions)

+ (call-using-types find-best-viable-function2 get-sequence name objects class const-p)

+ (when method

+ (return (values method conversions))))))

+ (loop for method in viable-functions

+ finally (return (values best-method conversions)) do

+ (block next

+ (multiple-value-bind (rank method-conversions)

+ (funcall get-sequence method objects)

+ (when (and rank (conversion<= rank best-rank))

+ (when (conversion= rank best-rank)

+ ;; FIXME catch all ambigious overloads

+ (if const-p

+ (error "Ambigious overload ~A." method)

+ (when (const-p method)

+ ;; assume that the previous method is a non

+ ;; const one and thus more specific.

+ (return-from next))))

+ (setf best-rank rank)

+ (setf best-method method)

+ (setf conversions method-conversions)

+ (when (and (conversion= rank (make-match 'exact-match))

+ (not (xor const-p (const-p method))))

+ (return (values method conversions))))))))))

- (derived-p (object.type-of) (get-class type)))

+ (derived-p (object.type-of) (get-class type))

+ (find-smoke-class (get-class type)))

- (if (pointer-p to-type)

- ;; Insert a space before the #\*

- (let ((name (name to-type)))

- (concatenate 'string

- (subseq name 0 (1- (length name)))

- " *"))

- (name to-type)))))

+ (name to-type))))

- (assert (not (void-p type))

- ()

- "Conversion operators not supported by Smoke.

-Update to Smoke >= r955426.")

- (let ((to-class (find-smoke-class (get-class type))))

- (when (call-using-types find-best-viable-function2

- (if (using-typep)

- #'standard-conversion-sequence-using-types

- #'standard-conversion-sequence)

- (constructor-name (get-class type))

- (list object) to-class)

+ (let ((to-class (find-smoke-class (get-class type) nil)))

+ (when (and to-class

+ (call-using-types find-best-viable-function2

+ (if (using-typep)

+ #'standard-conversion-sequence-using-types

+ #'standard-conversion-sequence)

+ (constructor-name (get-class type))

+ (list object) to-class))

- (if (null arguments)

- (let ((method (find-smoke-method (smoke-class-of object-or-class)

- name)))

- (unless (valid-p method)

- (error (make-condition 'no-applicable-cxx-method

- :method name

- :class object-or-class

- :arguments arguments)))

- (if (static-p method)

- (s-call method (null-pointer))

- (s-call method (cast object-or-class (get-class method)))))

- (multiple-value-bind (method sequence)

- (find-best-viable-function name

- arguments

- (smoke-class-of object-or-class))

- (when (null method)

- (error (make-condition 'no-applicable-cxx-method

- :method name

- :class object-or-class

- :arguments arguments)))

- (if (static-p method)

- (apply #'call-sequence method (null-pointer) sequence arguments)

- (apply #'call-sequence method (cast object-or-class (get-class method)) [_$_]

- sequence arguments)))))

+ (multiple-value-bind (method sequence)

+ (find-best-viable-function name

+ arguments

+ (smoke-class-of object-or-class)

+ (when (typep object-or-class

+ 'smoke-standard-object)

+ (const-p object-or-class)))

+ (when (null method)

+ (error (make-condition 'no-applicable-cxx-method

+ :method name

+ :class object-or-class

+ :arguments arguments)))

+ (if (static-p method)

+ (apply #'call-sequence method (null-pointer) sequence arguments)

+ (apply #'call-sequence method (cast object-or-class (get-class method)) [_$_]

+ sequence arguments))))

+ #:const-p

- (when (and (enum-p method)

- ;; FIXME workaround for

- ;; http://lists.kde.org/?l=kde-bindings&m=123464781307375

- (not (string= (name (get-class method))

- "KGlobalSettings")))

+ (when (enum-p method)

Sun Aug 2 12:12:41 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cleanup C++ to Lisp translation

- ("translate" (:needs "package"))

- ("method" (:needs "clos" "overload-resolution"))

+ ("smoke-to-clos" (:needs "clos" "overload-resolution"))

- (:needs "smoke-c" "utils")

+ (:needs "smoke-c" "utils" "bindings")

- (:needs "package" "translate")

+ (:needs "package")

-(defvar *bindings* (make-hash-table))

+(defvar *bindings* (make-hash-table)

+ "The Smoke C++ binding classes to which virtual method calls are dispatched.")

+ "A C array."

-(defvar *smoke-modules* (make-hash-table))

+(defvar *smoke-modules* (make-hash-table)

+ "All loaded Smoke modules.")

-

- (assert value [_$_]

- ()

+ (assert value ()

- (setf (gethash (pointer-address (smoke-module-pointer smoke)) *smoke-id-class-map*)

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

+ *smoke-id-class-map*)

- (setf (id-class-map smoke)

- (make-hash-table)))

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

- (setf (gethash (id smoke-class)

- (id-class-map (smoke smoke-class)))

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

- (ret (gethash (id class)

- (id-class-map (smoke class)))))

+ (ret (gethash (id class) (id-class-map (smoke class)))))

-

-(defmethod closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))

+(defmethod closer-mop:validate-superclass ((class smoke-standard-class)

+ (superclass standard-class))

-(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))

+(defmethod closer-mop:validate-superclass ((class cxx:class)

+ (superclass smoke-standard-class))

-(defmethod reinitialize-instance :around

- ((class smoke-standard-class)

- &rest args &key direct-superclasses &allow-other-keys)

- (apply

- #'call-next-method class

- :direct-superclasses (or direct-superclasses

- (list (find-class

- 'smoke-standard-object))) args))

+;; Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default

+;; STANDARD-OBJECT.

+(defun init-smoke-standard-class (class next-method

+ &rest args &key direct-superclasses

+ &allow-other-keys)

+ (apply next-method class

+ :direct-superclasses (or direct-superclasses

+ (list (find-class 'smoke-standard-object)))

+ args))

-(defmethod initialize-instance :around

- ((class smoke-standard-class)

- &rest args &key direct-superclasses &allow-other-keys)

- "Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default STANDARD-OBJECT."

- (apply

- #'call-next-method class

- :direct-superclasses (or direct-superclasses

- (list (find-class 'smoke-standard-object)))

- args))

+(defmethod initialize-instance :around ((class smoke-standard-class) &rest args)

+ (apply #'init-smoke-standard-class class #'call-next-method args))

+

+(defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args)

+ (apply #'init-smoke-standard-class class #'call-next-method args))

-(defmethod reinitialize-instance :around

- ((class cxx:class)

- &rest args &key direct-superclasses &allow-other-keys)

- (assert (not (null direct-superclasses))

- (direct-superclasses)

- "No superclass supplied for class ~A" class)

- (let ((superclass (first direct-superclasses)))

- (assert (subtypep (class-of superclass) (find-class 'smoke-standard-class))

- ((first direct-superclasses))

- "The first superclass must be an subclass of an smoke class.")

- (apply

- #'call-next-method class

- :id (id superclass)

- :smoke (smoke superclass)

- :direct-superclasses direct-superclasses

- args)))

-(defmethod initialize-instance :around

- ((class cxx:class)

- &rest args &key direct-superclasses &allow-other-keys)

+(defun init-cxx-class (class next-method &rest args &key direct-superclasses

+ &allow-other-keys)

- [_$_]

- #'call-next-method class

+ next-method class

+(defmethod reinitialize-instance :around ((class cxx:class) &rest args)

+ (apply #'init-cxx-class class #'call-next-method args))

+ [_$_]

+(defmethod initialize-instance :around ((class cxx:class) &rest args)

+ (apply #'init-cxx-class class #'call-next-method args))

+

+ ;; The destructed callback can be the result of deleting the object

+ ;; in a finalizer. In that case the object is already removed from

+ ;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.

+ ;; It looks like there is no stack allocation in Qt virtual method signatures.

- (push (argument-to-lisp (mem-ref stack

- 'smoke-stack-item)

+ (push (argument-to-lisp (mem-ref stack 'smoke-stack-item)

- (transfer-ownership-to value object)))))))

+ (remove-object (pointer value))))))))

+ ; (transfer-ownership-to value object)))))))

+;; Receive virutal function calls.

- ;; FIXME:

- ;;(assert object

- ;; (object)

- ;; "No object for ~A to call ~A." object-ptr method)

- (if (and object (typep (class-of object) 'cxx:class))

- ;; Do not allow overwriting methods of classes the users has

- ;; not derived from (like in C++), to reduce overhead.

- (let* ((method (make-smoke-method

- :smoke (gethash (pointer-address

- (smoke-get-smoke binding))

- *smoke-modules*)

- :id method)))

- (loop

- (restart-case

- (return-from dispatch-method

- (let ((gf (get-gf-for-method method)))

- (declare (function gf))

- (if (null (gf-methods gf))

- (progn

- (when abstract

- (error "Abstract method ~A called."

- (method-declaration method)))

- nil)

- (if object

- (progn

- (put-returnvalue stack

- (apply gf object

- (stack-to-args

- (inc-pointer stack [_$_]

- (foreign-type-size

- 'smoke-stack-item))

- (get-first-argument method)))

- (return-type method)

- object)

- t)

- nil))))

- ;; Restarts to prevent stack unwinding across the C++ stack.

- (call-default ()

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Call default implementation ~A instead."

- method))

- :test (lambda (condition)

- (declare (ignore condition))

- (not abstract))

- (return-from dispatch-method nil))

- (use-returnvalue (return-value)

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Supply a return value for ~A."

- (method-declaration method)))

- :test (lambda (condition)

- (declare (ignore condition))

- (not (void-p (return-type method))))

- :interactive (lambda ()

- (format *query-io* "~&Enter a new return value: ")

- (multiple-value-list (eval (read *query-io*))))

- (put-returnvalue stack return-value [_$_]

- (return-type method)

- (get-object object-ptr))

- (return-from dispatch-method t))

- (return ()

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Return void for ~A."

- (method-declaration method)))

- :test (lambda (condition)

- (declare (ignore condition))

- (void-p (return-type method)))

- (return-from dispatch-method (values)))

- (retry ()

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Try again calling ~A." [_$_]

- (method-declaration method))))))

- nil))))

+ ;; The Lisp OBJECT can be gc'ed but we might still receive a

+ ;; QObject destructed event when the C++ instance is deleted in

+ ;; the finalizer. Thus OBJECT might be NIL.

+ (when (and object (typep (class-of object) 'cxx:class))

+ ;; Do not allow overwriting methods of classes the users has

+ ;; not derived from (like in C++), to reduce overhead.

+ (let* ((method (make-smoke-method

+ :smoke (gethash (pointer-address

+ (smoke-get-smoke binding))

+ *smoke-modules*)

+ :id method)))

+ (loop

+ (restart-case

+ (return-from dispatch-method

+ (let ((gf (get-gf-for-method method)))

+ (declare (function gf))

+ (if (null (gf-methods gf))

+ (progn

+ (when abstract

+ (error "Abstract method ~A of ~A called."

+ (method-declaration method) object))

+ nil)

+ (if object

+ (progn

+ (put-returnvalue

+ stack

+ (apply gf object

+ (stack-to-args

+ (inc-pointer stack (foreign-type-size

+ 'smoke-stack-item))

+ (get-first-argument method)))

+ (return-type method) object)

+ t)

+ nil))))

+ ;; Restarts to prevent stack unwinding across the C++ stack.

+ (call-default ()

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream

+ "Call default implementation ~A instead."

+ method))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (not abstract))

+ (return-from dispatch-method nil))

+ (use-returnvalue (return-value)

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Supply a return value for ~A."

+ (method-declaration method)))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (not (void-p (return-type method))))

+ :interactive (lambda ()

+ (format *query-io* "~&Enter a new return value: ")

+ (multiple-value-list (eval (read *query-io*))))

+ (put-returnvalue stack return-value [_$_]

+ (return-type method)

+ (get-object object-ptr))

+ (return-from dispatch-method t))

+ (return ()

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Return void for ~A."

+ (method-declaration method)))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (void-p (return-type method)))

+ (return-from dispatch-method (values)))

+ (retry ()

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Try again calling ~A." [_$_]

+ (method-declaration method))))))

+ nil))))

-(defmethod convert-to-class (smoke-class (object smoke-standard-object))

- (cast object smoke-class))

-

+;; The constructor name is the name of the class minus any namespace parts.

- (cerror "ignore" "~A has already been called for ~A."

- #'keep-wrapper object))

+ (cerror "ignore" "~A has already been added to ~A."

+ object new-owner))

- ((gf-methods :initform nil

+ ((gf-methods :initform nil :type list

- :type list

- :documentation "Generic functions for different argument counts."))

+ :documentation "gf for different argument counts."))

- (:documentation

- "A generic function that can be overloaded by argument count."))

+ (:documentation "gf that can be overloaded by argument count."))

- (= argument-count

- (argument-count gf)))

+ (= argument-count (argument-count gf)))

- (let ((generic-function (ensure-gf-by-argument-count cxx-generic-function

- (method-argument-count method))))

+ (let ((generic-function (ensure-gf-by-argument-count

+ cxx-generic-function

+ (method-argument-count method))))

-

-except object with a non virtual destructor which had their ownership transferred

-to C++.")

+except object with a non virtual destructor which had their ownership

+transferred to C++.")

-(defun remove-if-exists (pointer)

- (remhash (pointer-address pointer) *object-map*))

-

- (declare (optimize (speed 3)))

- [_$_]

+ [_$_]

- (assert (not (has-pointer-p (pointer object)))

- ()

+ (assert (not (has-pointer-p (pointer object))) ()

- ((id :initform 0 :type smoke-index :reader id :initarg :id)

- (smoke :type smoke-module :reader smoke :initarg :smoke)))

+ ((id :initform 0 :type smoke-index

+ :reader id :initarg :id)

+ (smoke :type smoke-module

+ :reader smoke :initarg :smoke)))

-

- (mem-aref (the foreign-pointer (smoke-array-pointer (smoke-module-classes

- (smoke class))))

+ (mem-aref (the foreign-pointer

+ (smoke-array-pointer (smoke-module-classes (smoke class))))

- (declare (optimize (speed 3)))

+ (declare (type smoke-class class)

+ (optimize (speed 3)))

-;smoke-find-class

- (smoke-is-derived-from (smoke-module-pointer (smoke class)) (id class)

- (smoke-module-pointer (smoke base-class)) (id base-class)))

+ (smoke-is-derived-from (smoke-module-pointer (smoke class)) [_$_]

+ (id class)

+ (smoke-module-pointer (smoke base-class))

+ (id base-class)))

- class (append classes

- (list

- (make-smoke-class-from-id (smoke class)

- class-index)))

+ class

+ (append classes

+ (list (make-smoke-class-from-id (smoke class) class-index)))

-;;;

- enum-type)

+ enum-type)

- (enum-type enum2))

+ (enum-type enum2))

- collect `(,(value (eval (first case)))

- ,@(rest case)))))

+ collect `(,(value (eval (first case)))

+ ,@(rest case)))))

- (if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method)))

+ (if (or (null-pointer-p (smoke-module-pointer

+ (smoke-method-smoke smoke-method)))

- (the (smoke-index 0)

- (method-slot-value method 'name))))

+ (the (smoke-index 0) (method-slot-value method 'name))))

- (format nil "~A~:[~; static~]" (access method)

- (static-p method)))

+ (format nil "~A~:[~; static~]" (access method) (static-p method)))

-

- :top (inc-pointer smoke-stack

- #.(foreign-type-size 'smoke-stack-item))))

+ :top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item))))

- (setf (foreign-slot-value (call-stack-top stack)

- 'smoke-stack-item type) value)

+ (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)

+ value)

- 'smoke-stack-item ,type) ,value)

+ 'smoke-stack-item ,type)

+ ,value)

- (0 (let ((cffi-type (get-type (name type))))

- (if (null cffi-type)

- (progn [_$_]

- ;; FIXME warn but not on void**

- ;;(warn "Unknown translation from ~A to lisp." (name type))

- (foreign-slot-value stack-item 'smoke-stack-item 'voidp))

- (let* ((pointer (foreign-slot-value stack-item

- 'smoke-stack-item

- 'voidp))

- (value (convert-from-foreign pointer cffi-type)))

- (when (stack-p type)

- ;; FIXME free-translated-object is not intended for this;

- ;; param is NIL for now.

- (cffi:free-translated-object pointer cffi-type nil))

- value

- ))))

+ (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))

+ (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

+ 'voidp)))

+ (prog1 (funcall (car translation) pointer)

+ (when (stack-p type)

+ (funcall (cdr translation) pointer))))

+ (error "Do not know how to convert the type ~A to Lisp." type)))

- :value (foreign-slot-value stack-item 'smoke-stack-item 'enum-value)

+ :value (foreign-slot-value stack-item 'smoke-stack-item

+ 'enum-value)

- (if (class-p type)

- (let ((class (get-class type)))

- (if (has-pointer-p object)

+ (let ((class (get-class type)))

+ (if (has-pointer-p object)

+ (if (derived-p (class-of (get-object object))

+ (get-class type))

- (instance-to-lisp object (find-smoke-class class) type)))

- nil))

+ (progn

+ (cerror "Remove the old object."

+ "The object at pointer ~A is ~A but should be a ~A."

+ object (get-object object) type)

+ (remove-object object)

+ (instance-to-lisp object (find-smoke-class class) type)))

+ (instance-to-lisp object (find-smoke-class class) type))))

- (object-to-lisp (foreign-slot-value stack-item

- 'smoke-stack-item

+ (object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item

- ((void-p type)

- (values))

- ((class-p type)

- (class-to-lisp stack-item type))

- (t

- (enum-to-lisp stack-item type))))

+ ((void-p type) (values))

+ ((class-p type) (class-to-lisp stack-item type))

+ (t (enum-to-lisp stack-item type))))

+

+(defvar *to-lisp-translations* (make-hash-table :test 'equal))

+

+(defun error-no-free (object)

+ (error "Can not free object at ~A." object))

+

+(defmacro define-to-lisp-translation (type-names &optional

+ (conversion-function-name 'identity)

+ (free-function-name 'error-no-free))

+ `(progn ,@(loop for type-name in (ensure-list type-names)

+ collect `(setf (gethash ,type-name *to-lisp-translations*)

+ (cons ',conversion-function-name

+ ',free-function-name)))))

+

+(defmacro define-pointer-typedef (type-names lisp-type)

+ (declare (ignore lisp-type))

+ `(progn [_$_]

+ (define-to-lisp-translation ,type-names identity identity)))

+ ;; not needed

+ ;;(define-from-lisp-translation ,type-names ,lisp-type)))

+

+(define-to-lisp-translation ("void*" "const void*" "void**"))

+

+(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)

- ;; Can't just use #'get-type-flag since it

- ;; can only be one of :stack, :reference and :pointer.

+ ;; Can't just use #'get-type-flag since it can only be one of

+ ;; :stack, :reference and :pointer.

- (= 0 (mem-ref (mem-aref (smoke-array-pointer

- (smoke-module-types (smoke type)))

- 'smoke-type

- (the smoke-index (id type)))

- :char)))

+ (zerop (mem-ref (mem-aref (smoke-array-pointer

+ (smoke-module-types (smoke type)))

+ 'smoke-type

+ (the smoke-index (id type)))

+ :char)))

- (assert (/= -1 (type-slot-value type 'class))

+ (assert (class-p type)

- "The type ~S is not a smoke class." (name type))

- (make-smoke-class-from-id

- (smoke type)

- (type-slot-value type 'class)))

+ "The type ~S is not a smoke class." type)

+ (make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))

+ ;;

+ ;; But it is needed for passing the int pointer in QApplication(int&, char**).

- :from (find-class 't)

- :to (find-class 't)))) ;; FIXME get the class when applicable

+ :from (find-class 't)

+ :to (find-class 't)))) ;; FIXME get the class when applicable

+ #:define-to-lisp-translation

+ #:define-pointer-typedef

+#include <QDebug>

+ * @param class_index Index of the object's class.

-

-

- 'smoke-class

- 'class-function)

+ 'smoke-class 'class-function)

- 'smoke-method

- 'method)

+ 'smoke-method 'method)

-

- (s-call

- (make-smoke-method-from-name class method-name)

- pointer args))

+ (s-call (make-smoke-method-from-name class method-name) pointer args))

- (s-call

- (make-smoke-method-from-name (make-smoke-class smoke class-name)

- method-name)

- (null-pointer) args))

+ (s-call (make-smoke-method-from-name (make-smoke-class smoke class-name)

+ method-name)

+ (null-pointer) args))

+ ;;

- ;; and confuses it with the member function type() ??

- ;; (27.2.09)

+ ;; and confuses it with the member function type() ?? (27.2.09)

- (s-call

- (make-smoke-method-from-name class method-name)

- pointer)))

+ (s-call (make-smoke-method-from-name class method-name) pointer)))

- (make-smoke-method-from-name (class-of object) method-name)

- (pointer object)))

+ (make-smoke-method-from-name (class-of object) method-name)

+ (pointer object)))

- (setf (foreign-slot-value (mem-aref stack

- 'smoke-stack-item

- 1)

- 'smoke-stack-item

- 'voidp)

+ (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1)

+ 'smoke-stack-item 'voidp)

- 'smoke-class

- 'class-function)

+ 'smoke-class 'class-function)

- :pointer (pointer object) smoke-stack stack

+ :pointer (pointer object)

+ smoke-stack stack

- (let* ((binding (smoke-init smoke

- (callback destructed)

+ (let* ((binding (smoke-init smoke (callback destructed)

- (setf (gethash (pointer-address (smoke-module-pointer (eval symbol))) pointer-symbol-map)

+ (setf (gethash (pointer-address (smoke-module-pointer (eval symbol)))

+ pointer-symbol-map)

- (smoke-call (class-of object)

- (pointer object)

- method-name

- args))

+ (smoke-call (class-of object) (pointer object)

+ method-name args))

-

+

- (defcvar (,variable ,variable-name

- :read-only t

- :library ,library) :pointer)

+ (defcvar (,variable ,variable-name :read-only t :library ,library)

+ :pointer)

-

-(in-package :smoke)

-

-(defvar *type-map* (make-hash-table :test 'equal))

-

-(defun get-type (name)

- "Return the CFFI type for NAME."

- (gethash name *type-map*))

-

-(defun add-type (name type)

- "Registers the CFFI type TYPE with NAME."

- (setf (gethash name *type-map*) type))

-

-(defun setup-type-map ()

- "Setup C string <-> Lisp string translation."

- (add-type "char*" :string)

- (add-type "const char*" :string))

-

-(eval-when (:load-toplevel :execute)

- (setup-type-map))

-

-(defgeneric convert-to-class (smoke-class object))

-

-;(defmethod convert-to-class (smoke-class (pointer cffi:foreign-pointer))

-(defmethod convert-to-class (smoke-class pointer)

- (declare (ignore smoke-class))

- (assert (cffi:pointerp pointer))

- pointer)

Fri Jul 24 15:32:23 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix conversion sequence from QByteArray to const char*.

+(defun conversion-operator-name (to-type)

+ (concatenate 'string

+ "operator "

+ (if (class-p to-type)

+ (name (get-class to-type))

+ (if (pointer-p to-type)

+ ;; Insert a space before the #\*

+ (let ((name (name to-type)))

+ (concatenate 'string

+ (subseq name 0 (1- (length name)))

+ " *"))

+ (name to-type)))))

+

+(defun coerce-to-type (object method)

+ (pointer-call method (pointer object)))

+ [_$_]

- (format nil "operator ~A" [_$_]

- (if (class-p type)

- (name (get-class type))

- (name type))))))

+ (conversion-operator-name type))))

- (make-match 'user-conversion

- (lispify (name method) :cxx))))))

+ (if (pointer-p type)

+ (make-match 'user-conversion

+ 'coerce-to-type

+ method)

+ (make-match 'user-conversion

+ (lispify (name method) :cxx)))))))

Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs

-Methods:

- * C++ overload resolution & argument promotion

- => no more writing (make-instance 'qt:byte-array :args ("foo"))

- * Test for null pointer in this and for references

- * default arguments

- * fetch name of arguments

-

-* const correctness

-

-* keyword arguments for make-instance

-

-* QApplication and KCmdLineArgs.init call exit() on e.g. "--help"

-

-Testsuite:

- * Fix segfaults when lots of qt:applictions are created & deleted

- * Test condition & restarts

-

-finalization:

- * get rid of owned-p

- * use QObject::deleteLater ?

-

-* Exceptions

- ;; At least on sbcl 1.0.25.debian CONCATENATE is faster

- ;; than VECTOR-PUSH-EXTEND

+ ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than

+ ;; VECTOR-PUSH-EXTEND.

- T)

+ t)

- T)

+ t)

- ((object-pointer :pointer))

+ ((object-pointer :pointer))

- 'smoke-stack-item)

- arg)

+ 'smoke-stack-item)

+ arg)

+ ;;

- ;; passed on the stack. E.g. converted-value can be something like

- ;; (cxx:operator-variant value).

+ ;; passed on the stack. E.g. converted-value can be something

+ ;; like (cxx:operator-variant value).

- ;; Do not allow overwriting methods of classes the users has not derived from (like in C++),

- ;; to reduce overhead.

+ ;; Do not allow overwriting methods of classes the users has

+ ;; not derived from (like in C++), to reduce overhead.

- :smoke (gethash (pointer-address (smoke-get-smoke binding))

+ :smoke (gethash (pointer-address

+ (smoke-get-smoke binding))

+(defun constructor-name (class)

+ (let ((name-start (search "::" (name class) :from-end t)))

+ (if name-start

+ (subseq (name class) (+ name-start 2))

+ (name class))))

+

- (name (class-of object)))))

+ (constructor-name (class-of object)))))

+ (assert (valid-p method)

+ (method)

+ "No constructor for ~A." object)

- (find-best-viable-function (name (class-of object))

+ (find-best-viable-function (constructor-name (class-of object))

- (error "No constructor ~A for ~S"

- object arguments))

+ (error "No constructor for object ~A with

+the arguments ~S." object arguments))

- &key args &allow-other-keys)

+ &key args

+ (arg0 nil arg0p)

+ (arg1 nil arg1p)

+ (arg2 nil arg2p)

+ &allow-other-keys)

- (setf (slot-value object 'pointer) (call-constructor object args))

+ (if arg0p

+ (setf (slot-value object 'pointer) [_$_]

+ (call-constructor object [_$_]

+ (cond

+ (arg2p (list arg0 arg1 arg2))

+ (arg1p (list arg0 arg1))

+ (t (list arg0)))))

+ (setf (slot-value object 'pointer) (call-constructor object args)))

- (assert (has-pointer-p pointer)

- (pointer)

- "No object to remove for pointer ~A." pointer)

- (remhash (pointer-address pointer) *object-map*))

+ (unless (remhash (pointer-address pointer) *object-map*)

+ (cerror "ignore" "No object to remove for pointer ~A." pointer)))

+

+(defun debug-finalize ()

+ (eval '(defmethod make-finalize :around (object)

+ (let ((pointer (pointer object))

+ (class (class-of object))

+ (next (call-next-method)))

+ #'(lambda ()

+ (format *debug-io* "cl-smoke: finalizing: ~A..."

+ (make-instance class :pointer pointer))

+ (funcall next)

+ (format *debug-io* "done~%"))))))

- (assert (<= class-index

- (smoke-array-length

- (smoke-module-classes (smoke class)))))

+ (assert (<= class-index (smoke-array-length

+ (smoke-module-classes (smoke class)))))

- (smoke-add-superclass class (append classes

- (list

- (make-smoke-class-from-id (smoke class)

- class-index)))

- (1+ index)))))

+ (smoke-add-superclass

+ class (append classes

+ (list

+ (make-smoke-class-from-id (smoke class)

+ class-index)))

+ (1+ index)))))

+(declaim (inline smoke-method-name))

+(defun smoke-method-name (method)

+ (mem-aref (smoke-array-pointer (smoke-module-method-names [_$_]

+ (smoke-method-smoke method)))

+ :pointer

+ (the (smoke-index 0)

+ (method-slot-value method 'name))))

+

- (/ [_$_]

- (- (pointer-address (call-stack-top stack))

- (pointer-address (call-stack-pointer stack)))

- (foreign-type-size 'smoke-stack-item)))

+ (/ (- (pointer-address (call-stack-top stack))

+ (pointer-address (call-stack-pointer stack)))

+ (foreign-type-size 'smoke-stack-item)))

-(defun cstring= (string1 string2)

- "Returns T when the C strings STRING1 and STRING2 are equal

- and NIL otherwise."

- (declare (optimize (speed 3) (safety 0)))

- (dotimes (i array-total-size-limit)

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring= nil))

- (when (or (= 0 char1)

- (= 0 char2))

- (return-from cstring= (= char1 char2))))))

-

- "Returns -1 if a < b; 0 if a = b and 1 if a > b"

- (declare (values (integer -1 1)))

- (if (< a b)

- -1

- (if (> a b)

- 1

- 0)))

+ (- a b))

-(declaim (inline cstring-cmp))

-(defun cstring-cmp (string1 string2)

- "Compares the C strings STRING1 and STRING2."

- (declare (foreign-pointer string1 string2)

- (values (integer -1 1))

- (optimize (speed 3)))

- (dotimes (i array-total-size-limit (error "omg"))

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring-cmp (if (< char1 char2) -1 1)))

- (when (= 0 char1) ;; <=> (= 0 char2)

- (return-from cstring-cmp 0)))))

+(declaim (inline strcmp))

+(defcfun strcmp :int (s1 :pointer) (s2 :pointer))

+(declaim (inline cstring/=))

- (declare (optimize (speed 3)))

- (dotimes (i array-total-size-limit)

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring/= i))

- (when (= 0 char1)

- (return-from cstring/= nil)))))

-

-(declaim (inline smoke-method-name))

-(defun smoke-method-name (method)

- (mem-aref (smoke-array-pointer (smoke-module-method-names [_$_]

- (smoke-method-smoke method)))

- :pointer

- (the (smoke-index 0)

- (method-slot-value method 'name))))

+ (not (zerop (strcmp string1 string2))))

- (values (integer -1 1))

- (declare (type (integer -1 1) id-cmp)

- (dynamic-extent id-cmp))

+ (declare (type smoke-index id-cmp))

- (cstring-cmp (smoke-method-name method)

+ (strcmp (smoke-method-name method)

-;;; INLINE OPTIMIZE

- (cmp (the (integer -1 1) (method-cmp method class-id name))))

- (declare (type (integer -1 1) cmp)

+ (cmp (the smoke-index (method-cmp method class-id name))))

+ (declare (type smoke-index cmp)

- (ecase cmp

- (-1 (setf start (1+ index)))

- (0 (return-from find-method-for-class index))

- (1 (setf end (1- index)))))))

+ (if (< cmp 0)

+ (setf start (1+ index))

+ (if (> cmp 0)

+ (setf end (1- index))

+ (return-from find-method-for-class index))))))

- ,index))

+ (the smoke-index ,index)))

+ ;;

- (let ((methods)

- (smoke (smoke class)))

+ (let ((methods))

- (let ((start-index (find-method-for-class name class)))

- (declare (type smoke-index start-index))

- (loop for index from start-index downto 1

- while (push-candidate-method index name argument-count class

- methods))

- (loop for index from (1+ start-index)

- to (the smoke-index (smoke-array-length

- (smoke-module-method-maps smoke)))

- while (push-candidate-method index name argument-count class

- methods))))

+ (let ((smoke (smoke class)))

+ (let ((start-index (find-method-for-class name class)))

+ (declare (type smoke-index start-index))

+ (when (>= start-index 0)

+ (loop for index from start-index downto 1

+ while (push-candidate-method index name argument-count class

+ methods))

+ (loop for index from (1+ start-index)

+ to (the smoke-index (smoke-array-length

+ (smoke-module-method-maps smoke)))

+ while (push-candidate-method index name argument-count class

+ methods))))))

-(eval-when (:compile-toplevel :load-toplevel :execute)

-(defconstant +exact-match+ 0)

-(defconstant +promotion+ 1)

-(defconstant +conversion+ 2))

-

-(defstruct (exact-match (:include conversion (rank +exact-match+))))

+(defstruct (exact-match (:include conversion (rank 0))))

-(defstruct (promotion (:include conversion (rank +promotion+))))

+(defstruct (promotion (:include conversion (rank 1))))

-(defstruct (number-conversion (:include conversion (rank +conversion+))))

+(defstruct (number-conversion (:include conversion (rank 2))))

-(defstruct (pointer-conversion (:include conversion (rank (1+ +conversion+))))

+(defstruct (pointer-conversion (:include conversion (rank 3)))

-(defstruct (boolean-conversion (:include conversion (rank (+ 2 +conversion+)))))

+(defstruct (boolean-conversion (:include conversion (rank 4))))

-(defstruct (user-conversion (:include conversion (rank (+ 3 +conversion+)))))

+(defstruct (user-conversion (:include conversion (rank 5))))

- t)

- (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))

- (and (not (conversion< conversion1 conversion2))

- (not (conversion< conversion2 conversion1)))))

+ t))

+ (8 (object.typep '(c-integer :long)))

+ (9 (object.typep '(c-integer :unsigned-long)))

- ;; Not using pointer-p to allow passing a raw pointer for

- ;; objects on the stack and references

+ ;; Not using pointer-p to allow passing a raw pointer for objects on

+ ;; the stack and references.

- ;; FIXME this breaks passing pointers to references

- ;; e.g.: calling the function foo(QByteArray& foo)

- ;; with (foo pointer) assumes pointer to point to a QByteArray,

- ;; but actually the conversion sequence QByteArray(pointer) should be used.

- ;; When pointer is a null pointer it fails horribly!.

+ ;; FIXME this breaks passing pointers to references.

+ ;; [_$_]

+ ;; e.g.: calling the function foo(QByteArray& foo) with

+ ;; (foo pointer) assumes pointer to point to a QByteArray, but

+ ;; actually the conversion sequence QByteArray(pointer) should be

+ ;; used. When pointer is a null pointer it fails horribly!.

- (format nil "~A" (name (get-class type)))

+ (constructor-name (get-class type))

+ #:make-auto-pointer

- (let ((method-name (concatenate 'string "~" (name class))))

+ (let ((method-name (concatenate 'string "~" (constructor-name class))))

- pointer))

- (setf pointer (null-pointer)))

+ pointer)))

-;; No eql T since all-methods is to slow to be used in conjunction with

-;; mb:document

-(defmethod documentation ((gf smoke-gf) (doc-type (eql 'cxx-function)))

+(defmethod documentation ((gf smoke-gf) (doc-type (eql 't)))

+

+(declaim (inline cstring=))

+(defun cstring= (string1 string2)

+ "Returns T when the C strings STRING1 and STRING2 are equal

+ and NIL otherwise."

+ (zerop (strcmp string1 string2)))

+

- (declare (string name)

- (optimize (speed 3)))

+ (declare (optimize (speed 3)))

+ (with-foreign-string (name name)

- #'(lambda (address value)

- (declare (ignore value))

- (let ((smoke (make-pointer address)))

- (map-methods #'(lambda (method)

- (when (and (string= name (name method))

- (not (enum-p method)))

- (push (make-instance 'smoke-method

- :id (smoke-method-id method)

- :smoke (smoke method))

- methods)))

- smoke)))

- *smoke-id-class-map*)

- methods))

+ #'(lambda (address module)

+ (declare (ignore address))

+ (map-methods #'(lambda (method)

+ (when (and (cstring= name (smoke-method-name method))

+ (not (enum-p method)))

+ (push (make-smoke-method

+ :id (smoke-method-id method)

+ :smoke (smoke-method-smoke method))

+ methods)))

+ module))

+ *smoke-modules*)

+ methods)))

- (eval-when (:compile-toplevel :load-toplevel :execute)

- (define-foreign-library ,library

- (:unix ,(format nil "~(~A~).so.2" library))

- (t (:default ,(format nil "~(~A~)" library)))))

+ (eval-when (:compile-toplevel :load-toplevel :execute)

+ (define-foreign-library ,library

+ (:unix ,(format nil "~(~A~).so.2" library))

+ (t (:default ,(format nil "~(~A~)" library)))))

- (load-foreign-library ',library))

+ (load-foreign-library ',library))

-; (eval-when (:compile-toplevel :load-toplevel :execute)

-; (define-foreign-library ,library

-; (:unix ,(format nil "~(~A~).so.2" library))

-; (t (:default ,(format nil "~(~A~)" library))))

-; (load-foreign-library ',library))

Wed Jul 8 22:41:19 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Speedup overload resolution and some other stuff for faster C++ method calling.

- ((pointer :type smoke-standard-class))

+ ()

-(defmethod pointer ((class cxx:class))

- (pointer (slot-value class 'pointer)))

-

- :pointer superclass

+ :id (id superclass)

- :pointer superclass

+ :id (id superclass)

- :pointer [_$_]

- (pointer class)

- ;(mem-aref (smoke-array-pointer [_$_]

- ; (smoke-module-classes

- ; (smoke class)))

- ; 'smoke-class

- ; (id class))

+ :id (id class)

- (setf (top stack) (pointer stack))

+ (setf (call-stack-top stack) (call-stack-pointer stack))

+ (declare (optimize (speed 3)))

- ;(id (class-of object)) (id (real-class class))))

-

- (eval-startup (:execute)

- (make-smoke-classes ,package ,smoke)

+ (eval-startup (:load-toplevel :execute)

+ ;; eval on startup for class map.

+ (make-smoke-classes ,package ,smoke))

+ (eval-when (:load-toplevel :execute)

- ;; FXIME maybe change back to id

- ((pointer ;:type foreign-pointer

- :initarg :pointer

- :reader pointer)

- (smoke :type smoke-module

- :initarg :smoke

- :reader smoke))

- (:documentation "A class"))

+ ((id :initform 0 :type smoke-index :reader id :initarg :id)

+ (smoke :type smoke-module :reader smoke :initarg :smoke)))

- (make-instance 'smoke-class

- :pointer (mem-aref (smoke-array-pointer (smoke-module-classes

- smoke))

- 'smoke-class

- id)

- :smoke smoke))

+ (make-instance 'smoke-class :id id :smoke smoke))

-(defmethod id ((class smoke-class))

- (declare (values (smoke-index 0))

- (optimize (speed 3)))

- (values

- (floor

- (the (integer 0)

- (- (pointer-address (pointer class))

- (pointer-address (smoke-array-pointer (smoke-module-classes

- (smoke class))))))

- #.(cffi:foreign-type-size 'smoke-class))))

+

+(declaim (inline smoke-class-pointer))

+(defun smoke-class-pointer (class)

+ (mem-aref (the foreign-pointer (smoke-array-pointer (smoke-module-classes

+ (smoke class))))

+ 'smoke-class

+ (the smoke-index (id class))))

- (foreign-slot-value (pointer class)

+ (foreign-slot-value (smoke-class-pointer class)

- `(foreign-slot-value (pointer ,class)

+ `(foreign-slot-value (smoke-class-pointer ,class)

- (setf (slot-value class 'pointer)

- (mem-aref (smoke-array-pointer (smoke-module-classes smoke))

- 'smoke-class

- id))

+ (setf (slot-value class 'id)

+ id)

- :pointer (smoke-get-class [_$_]

- (foreign-slot-value c 'smoke-module-index 'smoke)

- (foreign-slot-value c 'smoke-module-index 'index))

+ :id (foreign-slot-value c 'smoke-module-index 'index)

+ (declare (optimize (speed 3)))

- (call-next-method)))

+ (the smoke-index (call-next-method))))

-(defclass call-stack ()

- ((pointer :reader pointer :initarg :pointer

- :initform (null-pointer)

- :type foreign-pointer

- :documentation "Pointer to the Smoke stack")

- (top :accessor top :initarg :top

- :initform (null-pointer)

- :type foreign-pointer

- :documentation "Pointer to push the next argument to."))

- (:documentation "Contains the argument passed to a Smoke method."))

+(declaim (inline %make-call-stack))

+(defstruct (call-stack (:constructor %make-call-stack))

+ (pointer (null-pointer) :type foreign-pointer)

+ (top (null-pointer) :type foreign-pointer))

- (- (pointer-address (top stack))

- (pointer-address (pointer stack)))

+ (- (pointer-address (call-stack-top stack))

+ (pointer-address (call-stack-pointer stack)))

- (declare (optimize (speed 3)))

- (make-instance 'call-stack

- :pointer smoke-stack

- :top (inc-pointer smoke-stack (foreign-type-size 'smoke-stack-item))))

+ (declare (type foreign-pointer smoke-stack)

+ (optimize (speed 3)))

+ (%make-call-stack

+ :pointer smoke-stack

+ :top (inc-pointer smoke-stack

+ #.(foreign-type-size 'smoke-stack-item))))

- (setf (foreign-slot-value (top stack)

+ (setf (foreign-slot-value (call-stack-top stack)

- (incf-pointer (top stack) #.(foreign-type-size 'smoke-stack-item)))

+ (incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))

- (setf (foreign-slot-value (top ,stack)

+ (setf (foreign-slot-value (call-stack-top ,stack)

- (incf-pointer (top ,stack) ,(foreign-type-size 'smoke-stack-item)))

+ (incf-pointer (call-stack-top ,stack)

+ ,(foreign-type-size 'smoke-stack-item)))

+ :type foreign-pointer

+ (declare (optimize (speed 3)))

- (id type))

+ (the smoke-index (id type)))

+;;; INLINE OPTIMIZE

+(declaim (inline first-unabigious-index))

- (declare (type (smoke-index 0) start end))

+ (declare (type (smoke-index 0) start end)

+ (dynamic-extent start))

- (dynamic-extent method index cmp))

+ (dynamic-extent method))

-(defclass std-conversion ()

- ((function-name :accessor conversion-function-name

- :initarg :conversion-function-name))

- (:documentation "A conversion"))

+(declaim (inline make-conversion make-exact-match make-promotion

+ make-number-conversion make-pointer-conversion

+ make-boolean-conversion make-user-conversion))

+(defstruct conversion

+ (function-name nil :type (or symbol function) :read-only t)

+ (rank -1 :type fixnum :read-only t))

-(defclass exact-match (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform +exact-match+)))

+(defstruct (exact-match (:include conversion (rank +exact-match+))))

-(defclass promotion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform +promotion+)))

+(defstruct (promotion (:include conversion (rank +promotion+))))

-(defclass number-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform +conversion+)))

+(defstruct (number-conversion (:include conversion (rank +conversion+))))

-(defclass pointer-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform (1+ +conversion+))

- (from :reader from

- :initarg :from)

- (to :reader to

- :initarg :to)))

+(defstruct (pointer-conversion (:include conversion (rank (1+ +conversion+))))

+ (from (find-class t) :type class :read-only t)

+ (to (find-class t) :type class :read-only t))

-(defclass boolean-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform (+ 2 +conversion+))))

+(defstruct (boolean-conversion (:include conversion (rank (+ 2 +conversion+)))))

-(defclass user-conversion (std-conversion)

- ((rank :reader rank

- :allocation :class

- :type fixnum

- :initform (+ 3 +conversion+))))

+(defstruct (user-conversion (:include conversion (rank (+ 3 +conversion+)))))

- (< (the fixnum (rank conversion1))

- (the fixnum (rank conversion2)))))

+ (< (the fixnum (conversion-rank conversion1))

+ (the fixnum (conversion-rank conversion2)))))

- (if (eq (from conversion1) (from conversion2))

+ (if (eq (pointer-conversion-from conversion1)

+ (pointer-conversion-from conversion2))

- (subtypep (to conversion1) (to conversion2))

- (if (eq (to conversion1) (to conversion2))

+ (subtypep (pointer-conversion-to conversion1)

+ (pointer-conversion-to conversion2))

+ (if (eq (pointer-conversion-to conversion1)

+ (pointer-conversion-to conversion2))

- (subtypep (from conversion1) (from conversion2))

+ (subtypep (pointer-conversion-from conversion1)

+ (pointer-conversion-from conversion2))

- (= (rank conversion1) (rank conversion2)))

+ (= (conversion-rank conversion1) (conversion-rank conversion2)))

- `(make-instance ,type

- :conversion-function-name ,(conversion-function name argument)

- [_$_]

+ `(,(symbolicate 'make- (eval type))

+ :function-name ,(conversion-function name argument)

- ;; FIXME only cast when needed.

- (cast object

- (find-class (quote ,(class-name [_$_]

- (find-smoke-class

- (get-class method))))))

+ ,(if (eql (type-specifier object)

+ (find-smoke-class (get-class method)))

+ `(pointer object)

+ `(cast object

+ (find-class (quote ,(class-name [_$_]

+ (find-smoke-class

+ (get-class method)))))))

- (foreign-slot-value (pointer (get-class method))

+ (foreign-slot-value (smoke-class-pointer (get-class method))

- (call-s-method method object-pointer (pointer stack))

- (type-to-lisp (pointer stack) (return-type method))))

+ (call-s-method method object-pointer (call-stack-pointer stack))

+ (type-to-lisp (call-stack-pointer stack) (return-type method))))

- (call-s-method method object-pointer (pointer stack))

- (foreign-slot-value (pointer stack) 'smoke-stack-item 'class)))

+ (call-s-method method object-pointer (call-stack-pointer stack))

+ (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class)))

- (call-s-method method (null-pointer) (pointer stack))

- (foreign-slot-value (pointer stack) 'smoke-stack-item 'long)))

+ (call-s-method method (null-pointer) (call-stack-pointer stack))

+ (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'long)))

- (foreign-slot-value (pointer (class-of object))

+ (foreign-slot-value (smoke-class-pointer (class-of object))

Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* SBCL: compile time overload resolution

+ ("sb-optimize" (:for :sbcl) (:needs "overload-resolution"))

- (if-let

- (match (call-using-type exact-match object type))

- (if (eql t match)

- (make-match 'exact-match)

- (make-match 'exact-match match))

- (or (call-using-type promotion object type)

- (call-using-type conversion object type)

- (and user

- (call-using-type user-conversion object type)))))

+ (if-let (match (call-using-type exact-match object type))

+ (if (eql t match)

+ (make-match 'exact-match)

+ (make-match 'exact-match match))

+ (or (call-using-type promotion object type)

+ (call-using-type conversion object type)

+ (and user

+ (call-using-type user-conversion object type)))))

+(in-package :smoke)

+

+(declaim (optimize (debug 3)))

+

+(defmacro catch-try ((tag &optional catch-result) catch-form &body body)

+ "Catch TAG in the BODY forms. When TAG is throw CATCH-RESULT is bound

+to the thrown values and result of CATCH-FORM is returned. Otherwise

+the result of BODY is returned and CATCH-FORM is not evaluated."

+ (flet ((catch-block (tag return-block body)

+ `(catch ,tag

+ (return-from ,return-block

+ ,@body))))

+ (let ((return-block (gensym)))

+ `(block ,return-block [_$_]

+ ,(if catch-result

+ `(let ((,catch-result ,(catch-block tag return-block body)))

+ ,catch-form)

+ `(progn ,(catch-block tag return-block body)

+ ,catch-form))))))

+

+(defun type-specifier (lvar)

+ (let ((type (sb-kernel:type-specifier (sb-c::lvar-type lvar))))

+ (if (subtypep type 'smoke-standard-object)

+ (find-class type)

+ type)))

+ [_$_]

+

+(defun give-up-transform (&rest args)

+ (apply #'sb-c::give-up-ir1-transform args))

+

+(defmacro define-transform (name lambda-list &body body)

+ `(sb-c:deftransform ,name (,lambda-list)

+ ,@body))

+

+(defmacro define-known (name)

+ `(sb-c:defknown ,name * *))

+

+(defun method-form (method)

+ `(make-smoke-method

+ :id ,(id method)

+ :smoke (eval ,(get-smoke-variable-for-pointer

+ (smoke method)))))

+ [_$_]

+(defun sequence-form (sequence arguments)

+ (mapcar #'(lambda (sequence argument)

+ (if (symbolp sequence)

+ `(,sequence ,argument)

+ `(,(first sequence) ,argument ,@(rest sequence))))

+ sequence arguments))

+

+

+(defmacro define-resolve-at-compile-time (gf-name)

+ `(eval-when (:compile-toplevel :load-toplevel :execute)

+ (define-known ,gf-name)

+ (sb-c:defoptimizer (,gf-name derive-type) ((object &rest args))

+ (catch-try ('unspecific-type) sb-c::*wild-type*

+ (let ((method (find-best-viable-function-using-types

+ ,(name (fdefinition gf-name))

+ (mapcar #'type-specifier args) (type-specifier object))))

+ (if (and method (class-p (return-type method)))

+ (sb-kernel:single-value-specifier-type

+ (find-smoke-class (get-class (return-type method))))

+ sb-c::*wild-type*))))

+ (define-transform ,gf-name (object &rest args)

+ (when (null args)

+ (give-up-transform "No arguments."))

+ (catch-try ('unspecific-type reason)

+ (give-up-transform "Could not resolve overload at compile time: ~A" reason)

+ (multiple-value-bind (method sequence)

+ (find-best-viable-function-using-types

+ ,(name (fdefinition gf-name))

+ (mapcar #'type-specifier args)

+ (type-specifier object))

+ (let ((argument-names (make-gensym-list (length args))))

+ (when (null method)

+ (give-up-transform "No applicable method."))

+ (if (static-p method)

+ `(s-call ,(method-form method)

+ (null-pointer)

+ (list ,@(sequence-form

+ sequence args)))

+ `(lambda (object ,@argument-names)

+ (s-call ,(method-form method)

+ ;; FIXME only cast when needed.

+ (cast object

+ (find-class (quote ,(class-name [_$_]

+ (find-smoke-class

+ (get-class method))))))

+ (list ,@(sequence-form

+ sequence argument-names)))))))))))

-false when it is not; and :MAYBE when the relationship

-could not be determined."

+false when it is not."

- nil

+ (if (and (subtypep type 'integer)

+ (not (integer-types-disjunct-p object-type type)))

+ (throw 'unspecific-type (values object-type type))

+ nil)

- #+nil [_$_]

- #+nil

+

+(defun integer-types-disjunct-p (type1 type2)

+ ;; FIXME implement this

+ (declare (ignore type1 type2))

+ nil)

Fri Jul 3 11:50:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix methods and method-maps bounds.

- (warn "life object ~A" (class-of object))

+ (warn "life object ~A" object)

- (loop for id from 1 to length do

+ (loop for id from 0 below length do ;; exception: methods is < lenght

- (end (smoke-array-length (smoke-module-method-maps smoke))))

+ (end (1+ (smoke-array-length (smoke-module-method-maps smoke)))))

Thu Jul 2 23:51:50 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Promption real to double-float

+(defun coerce-double-float (number)

+ (float number 0d0))

+

+;; FIXME incomplete

- (make-match 'promotion 'coerce-enum)))))

+ (make-match 'promotion 'coerce-enum)))

+ (11 (when (object.typep 'real)

+ (make-match 'promotion 'coerce-double-float)))))

Thu Jul 2 23:51:14 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix infinite loop when showing candidate functions.

-Candidates are:~{~T~%~}."

+Candidates are:~{~T~A~%~}."

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

* Fix undefine init_smoke* C function & cleanup finalizers when a image is saved.

- ("object-map" (:needs "objects"))

+ ("object-map" (:needs "objects" :utils))

- (:supports (:os :linux) (:implementation :sbcl :openmcl))

+(eval-on-save ()

+ (loop for object being the hash-value of *object-map* do

+ (warn "life object ~A" (class-of object))

+ (remove-finalizer object)

+ (setf (slot-value object 'pointer) (null-pointer)))

+ (clrhash *object-map*))

+

- (eval-startup (:compile-toplevel :execute)

- (t (:default ,(format nil "~(~A~)" library))))

- (use-foreign-library ,library))

- (defcvar (,variable ,variable-name :read-only t) :pointer)

+ (t (:default ,(format nil "~(~A~)" library)))))

+ (eval-startup (:compile-toplevel :execute)

+ (load-foreign-library ',library))

+ (eval-startup (:compile-toplevel :execute)

+; (eval-when (:compile-toplevel :load-toplevel :execute)

+; (define-foreign-library ,library

+; (:unix ,(format nil "~(~A~).so.2" library))

+; (t (:default ,(format nil "~(~A~)" library))))

+; (load-foreign-library ',library))

+ (defcvar (,variable ,variable-name

+ :read-only t

+ :library ,library) :pointer)

- function-name))

+ function-name)

+ :library ,library)

+(defmacro eval-on-save (() &body body)

+ `(eval-when (:load-toplevel)

+ (push #'(lambda ()

+ (let ((*package* ,*package*))

+ ,@body))

+ ccl:*save-exit-functions*)))

+

+(defmacro eval-on-save (() &body body)

+ `(eval-when (:load-toplevel)

+ (push #'(lambda ()

+ (let ((*package* ,*package*))

+ ,@body))

+ sb-ext:*save-hooks*)))

+

Wed Jul 1 12:54:01 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Spellcheck

-Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not neccessarily return

-a string equal to SMOME-STRING."

+Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not necessarily return

+a string equal to SOME-STRING."

- "Downcase, convert _ and dispatch."

+ "Down case, convert _ and dispatch."

- "Strip leadind Q or K."

+ "Strip leading Q or K."

- "Upcase, convert _ and dispatch."

+ "Up case, convert _ and dispatch."

- "No superclass suplied for class ~A" class)

+ "No superclass supplied for class ~A" class)

- "No superclass suplied for class ~A" class)

+ "No superclass sup-lied for class ~A" class)

- "Construts a lisp class in PACKAGE for each one in the Smoke module SMOKE."

+ "Constructs a lisp class in PACKAGE for each one in the Smoke module SMOKE."

- "Returns the class of OBJECT or OBJECT iff it alread is a class."

+ "Returns the class of OBJECT or OBJECT iff it already is a class."

- (error "No construtor ~A for ~S"

+ (error "No constructor ~A for ~S"

- "The method ~A must not contatin lambda list keywords." method))

+ "The method ~A must not contain lambda list keywords." method))

- ;; on startup and the eval stuff is slower.

+ ;; on start up and the eval stuff is slower.

- ;; -using-classes only cares abount the number of arguments;

+ ;; -using-classes only cares about the number of arguments;

- "Retruns a compiler-macro form for CXX-GENERIC-FUNCTION that

+ "Returns a compiler-macro form for CXX-GENERIC-FUNCTION that

-;;; mulitiple definiton of a function with the same name.

+;;; multiple definition of a function with the same name.

- (string/= (name method) "tr")) ;; we have a custom qt:tr funciton

+ (string/= (name method) "tr")) ;; we have a custom qt:tr function

-;; CLISP has problems with weak hashtables and finalizers.

+;; CLISP has problems with weak hash tables and finalizers.

-except object with a non virtual destuctor which had their ownership transfered

+except object with a non virtual destructor which had their ownership transferred

- "Adds OBJECT to the pointer -> object map. It can later be retrived

+ "Adds OBJECT to the pointer -> object map. It can later be retrieved

- "Applys FUNCTION to the classes of SMOKE."

+ "Applies FUNCTION to the classes of SMOKE."

-Signals an error when the method is ambigious."

+Signals an error when the method is ambiguous."

- (error "The method ~S of ~S is ambigious" name (name class))) ;;TODO

+ (error "The method ~S of ~S is ambiguous" name (name class))) ;;TODO

- "Applys FUNCTION to the methods of SMOKE.

+ "Applies FUNCTION to the methods of SMOKE.

- "Retruns T when METHOD is static and NIL otherwise."

+ "Returns T when METHOD is static and NIL otherwise."

- "Returns T when METHOD is ambigious and NIL otherwise."

+ "Returns T when METHOD is ambiguous and NIL otherwise."

- ;; since then they would be alway reacable from Lisp and thus

+ ;; since then they would be always reachable from Lisp and thus

- :documentation "Objecsts owned by the C++ instance."))

+ :documentation "Objects owned by the C++ instance."))

- "To many arguments suppliend (Arguments ~A)." args)

+ "To many arguments supplied (Arguments ~A)." args)

- (:documentation "Returns a clos instance for POINTER."))

+ (:documentation "Returns a CLOS instance for POINTER."))

- ;; For efficency just check if the first byte is a null byte;

+ ;; For efficiency just check if the first byte is a null byte;

- "Returns a list of all superclasses of CLASS and CLASS itself."

+ "Returns a list of all super-classes of CLASS and CLASS itself."

- "Retruns true when CONVERSION1 is better than CONVERSION2.")

+ "Returns true when CONVERSION1 is better than CONVERSION2.")

- "Retruns a conversion sequence to convert a instance of type CLASS

+ "Retrains a conversion sequence to convert a instance of type CLASS

- ;; FIXME test for ambigious overload #'conversion=

+ ;; FIXME test for ambiguous overload #'conversion=

-Candidtes are:~{~T~%~}."

+Candidates are:~{~T~%~}."

-Calls the destrutor and frees the memory."

+Calls the destructor and frees the memory."

- "could not remove temponary directory ~A"

+ "could not remove temporary directory ~A"

Wed Jul 1 00:47:39 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix for Clozure CL

- ((binding :pointer)

- (method smoke-index)

- (object-ptr :pointer)

- (stack smoke-stack)

- (abstract :boolean))

+ ((binding :pointer)

+ (method smoke-index)

+ (object-ptr :pointer)

+ (stack smoke-stack)

+ (abstract :boolean))

- (let* ((method (make-smoke-method

- :smoke (gethash (pointer-address (smoke-get-smoke binding))

- *smoke-modules*)

- :id method)))

- (loop

- (restart-case

- (return-from dispatch-method

- (let ((gf (get-gf-for-method method)))

- (declare (function gf))

- (if (null (gf-methods gf))

- (progn

- (when abstract

- (error "Abstract method ~A called."

- (method-declaration method)))

- nil)

- (let ((object (get-object object-ptr)))

- ;; FIXME:

- ;;(assert object

- ;; (object)

- ;; "No object for ~A to call ~A." object-ptr method)

- (if object

+ (let ((object (get-object object-ptr)))

+ ;; FIXME:

+ ;;(assert object

+ ;; (object)

+ ;; "No object for ~A to call ~A." object-ptr method)

+ (if (and object (typep (class-of object) 'cxx:class))

+ ;; Do not allow overwriting methods of classes the users has not derived from (like in C++),

+ ;; to reduce overhead.

+ (let* ((method (make-smoke-method

+ :smoke (gethash (pointer-address (smoke-get-smoke binding))

+ *smoke-modules*)

+ :id method)))

+ (loop

+ (restart-case

+ (return-from dispatch-method

+ (let ((gf (get-gf-for-method method)))

+ (declare (function gf))

+ (if (null (gf-methods gf))

- (put-returnvalue stack

- (apply gf object

- (stack-to-args

- (inc-pointer stack [_$_]

- (foreign-type-size

- 'smoke-stack-item))

- (get-first-argument method)))

- (return-type method)

- object)

- t)

- nil)))))

- ;; Restarts to prevent stack unwinding across the C++ stack.

- (call-default ()

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Call default implementation ~A instead."

- method))

- :test (lambda (condition)

- (declare (ignore condition))

- (not abstract))

- (return-from dispatch-method nil))

- (use-returnvalue (return-value)

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Supply a return value for ~A."

- (method-declaration method)))

- :test (lambda (condition)

- (declare (ignore condition))

- (not (void-p (return-type method))))

- :interactive (lambda ()

- (format *query-io* "~&Enter a new return value: ")

- (multiple-value-list (eval (read *query-io*))))

- (put-returnvalue stack return-value [_$_]

- (return-type method)

- (get-object object-ptr))

- (return-from dispatch-method t))

- (return ()

+ (when abstract

+ (error "Abstract method ~A called."

+ (method-declaration method)))

+ nil)

+ (if object

+ (progn

+ (put-returnvalue stack

+ (apply gf object

+ (stack-to-args

+ (inc-pointer stack [_$_]

+ (foreign-type-size

+ 'smoke-stack-item))

+ (get-first-argument method)))

+ (return-type method)

+ object)

+ t)

+ nil))))

+ ;; Restarts to prevent stack unwinding across the C++ stack.

+ (call-default ()

- (format stream "Return void for ~A."

+ (format stream "Call default implementation ~A instead."

+ method))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (not abstract))

+ (return-from dispatch-method nil))

+ (use-returnvalue (return-value)

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Supply a return value for ~A."

- (void-p (return-type method)))

- (return-from dispatch-method (values)))

- (retry ()

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Try again calling ~A." [_$_]

- (method-declaration method))))))))

+ (not (void-p (return-type method))))

+ :interactive (lambda ()

+ (format *query-io* "~&Enter a new return value: ")

+ (multiple-value-list (eval (read *query-io*))))

+ (put-returnvalue stack return-value [_$_]

+ (return-type method)

+ (get-object object-ptr))

+ (return-from dispatch-method t))

+ (return ()

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Return void for ~A."

+ (method-declaration method)))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (void-p (return-type method)))

+ (return-from dispatch-method (values)))

+ (retry ()

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Try again calling ~A." [_$_]

+ (method-declaration method))))))

+ nil))))

- :type (make-instance 'smoke-lazy-type

+ :type (make-instance 'smoke-type

- (register-smoke-module-var (quote ,smoke))

- ((pointer :type foreign-pointer

+ ((pointer ;:type foreign-pointer

+;; for the constants (e.g.: QT:+ALT+)

- (declare (ignore environment))

- :type (make-instance 'smoke::smoke-lazy-type

- :id ,(id (enum-type enum))

- :smoke ',(smoke::get-smoke-variable-for-pointer

- (smoke::smoke (enum-type enum))))))

+ :type ,(make-load-form (enum-type enum) environment)))

-(defclass smoke-lazy-type (smoke-type)

- ())

+;; Clozure CL needs this

+(defmethod make-load-form ((type smoke-type) &optional environment)

+ (declare (ignore environment))

+ `(make-instance 'smoke-type

+ :id ,(id type)

+ :smoke (eval ,(get-smoke-variable-for-pointer

+ (smoke-module-pointer (smoke type))))))

- (class-id (id class))

- (smoke (smoke class))

- (end (smoke-array-length (smoke-module-method-maps smoke))))

+ (class-id (id class))

+ (smoke (smoke class))

+ (end (smoke-array-length (smoke-module-method-maps smoke))))

-(declaim (inline call-s-method) (optimize (debug 3)))

+(declaim (inline call-s-method))

-; (declare (optimize (speed 3)))

+ (declare (optimize (speed 3)))

- (eval-when (:compile-toplevel :load-toplevel :execute)

- (define-foreign-library ,library

- (:unix ,(format nil "~(~A~).so.2" library))

- (t (:default ,(format nil "~(~A~)" library))))

- (use-foreign-library ,library))

- (defcvar (,variable ,variable-name :read-only t) :pointer)

- (defcfun (,init-function ,(format nil "_Z~A~Av"

- (length function-name)

- function-name))

- :void))

+ (eval-when (:compile-toplevel :load-toplevel :execute)

+ (define-foreign-library ,library

+ (:unix ,(format nil "~(~A~).so.2" library))

+ (t (:default ,(format nil "~(~A~)" library))))

+ (use-foreign-library ,library))

+ (defcvar (,variable ,variable-name :read-only t) :pointer)

+ (defcfun (,init-function ,(format nil "_Z~A~Av"

+ (length function-name)

+ function-name))

+ :void))

- (,init-function)

- (init ,variable ,smoke-module))

+ (,init-function)

+ (init ,variable ,smoke-module)

+ (register-smoke-module-var ',smoke-module))

+ (declare (ignorable ,@(loop for arg in (rest lambda-list) collect

+ (if (consp arg)

+ (first arg)

+ arg))))

+ccl --batch --quiet --load $0 || exit 3

-(sb-ext:quit)

+#+sbcl (sb-ext:quit)

+#+ccl (ccl:quit)

Tue Jun 30 22:54:49 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* CLISP workaround finalizer for objects in weak hash table crash.

- (cancel-finalization object)

+ (remove-finalizer object)

- (cancel-finalization converted-value)

+ (remove-finalizer converted-value)

- (cancel-finalization object)

+ (remove-finalizer object)

- (let ((finalizer (make-finalize object)))

- (finalize object finalizer)))

+ (set-finalizer object))

- #-cmucl (make-weak-hash-table :weakness #-clisp weakness

- ;; CLISP crash with weak hash table

- ;; leak memory (see also: #'keep-wrapper)

- #+clisp nil)

+ #-cmucl (make-weak-hash-table :weakness weakness)

+(declaim (inline remove-finalizer))

+(defun remove-finalizer (object)

+ #-clisp

+ (cancel-finalization object)

+ #+clisp

+ (when (typep object 'smoke-standard-object)

+ (cancel-finalization (slot-value object 'finalizer))))

+

+(declaim (inline set-finalizer))

+(defun set-finalizer (object)

+ #-clisp

+ (finalize object (make-finalize object))

+ #+clisp

+ (finalize (slot-value object 'finalizer) (make-finalize object)))

+

+ #+clisp (finalizer :type list :initform (list nil))

Mon Jun 22 14:18:08 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Speedup overload resolution by calling less into C, more efficient finding of the viable methods

and various optimizations.

This breaks Clozure CL -- fix it later.

-

-find_package(Qt4)

-set(QT_DONT_USE_QTGUI true)

-include(${QT_USE_FILE})

-

-find_library(SMOKE_KDE_LIBRARY smokekde)

-include(FindPackageHandleStandardArgs)

-find_package_handle_standard_args(smokekde DEFAULT_MSG SMOKE_KDE_LIBRARY)

-

-## kde-hello-world

-if(SMOKE_KDE_LIBRARY)

- include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../src/smoke-c/")

-

- add_executable(kde-hello-world kde-hello-world.cpp ../src/smoke-c/csmokebinding.cpp)

- target_link_libraries(kde-hello-world ${SMOKE_KDE_LIBRARY})

-endif(SMOKE_KDE_LIBRARY)

-/*

- * Copyright 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

- *

- * Permission is hereby granted, free of charge, to any person

- * obtaining a copy of this software and associated documentation

- * files (the "Software"), to deal in the Software without

- * restriction, including without limitation the rights to use,

- * copy, modify, merge, publish, distribute, sublicense, and/or sell

- * copies of the Software, and to permit persons to whom the

- * Software is furnished to do so, subject to the following

- * conditions:

- *

- * The above copyright notice and this permission notice shall be

- * included in all copies or substantial portions of the Software.

- *

- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

- * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES

- * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

- * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT

- * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,

- * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING

- * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR

- * OTHER DEALINGS IN THE SOFTWARE.

- */

-

-/**

- * Hello world example using libsmoke-c.

- * Display an KDE Window. */

-

-#include <smoke/qt_smoke.h>

-#include <smoke/kde_smoke.h>

-

-#include "smoke-c.cpp"

-

-#include <iostream>

-

-using namespace std;

-using namespace cl_smoke;

-

-static void

-destructed(Binding* binding, Smoke::Index class_id,

- void* object)

-{

- cout << "destructed: " << binding->className(class_id) << endl;

-}

-

-/** No method dispatch in this example. */

-static int

-dispatch(Binding* binding, Smoke::Index method,

- void* object, Smoke::Stack args, int abstract)

-{

- return false;

-}

-

-int

-main(int argc, char** argv)

-{

- init_kde_Smoke(); // calls also init_qt_Smoke();

- smoke_binding kde = smoke_init(kde_Smoke, reinterpret_cast<void*>(&destructed),

- reinterpret_cast<void*>(&dispatch));

- smoke_binding qt = smoke_init(qt_Smoke, reinterpret_cast<void*>(&destructed),

- reinterpret_cast<void*>(&dispatch));

-

- Smoke::StackItem stack[5];

- Smoke::ModuleIndex m;

- Smoke::ModuleIndex c;

-

- // bytearray = new QByteArray("foo");

- {

- char str[] = "foo";

-

- smoke_find_class(&c, qt_Smoke, "QByteArray");

- smoke_find_method(&m, qt_Smoke, c.index, "QByteArray$");

-

- stack[1].s_class = str;

-

- smoke_call_method(qt_Smoke, m.index, NULL, stack);

- }

- void* bytearray = stack[0].s_class;

-

-

- // l10n = ki18n(bar);

- {

- char str[] = "hello world";

- smoke_find_class(&c, kde_Smoke, "QGlobalSpace");

- smoke_find_method(&m, kde_Smoke, c.index, "ki18n$");

-

- stack[1].s_class = str;

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

- void* l10n = stack[0].s_class;

-

- // about = KAboutData(bytearray, bytearray, l10n, bytearray);

- {

- smoke_find_class(&c, kde_Smoke, "KAboutData");

- smoke_find_method(&m, kde_Smoke, c.index, "KAboutData####");

-

- stack[1].s_class = bytearray;

- stack[2].s_class = bytearray;

- stack[3].s_class = l10n;

- stack[4].s_class = bytearray;

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

- void* about = stack[0].s_class;

-

-

- // KCmdLineArgs::init(argc, argv, about);

- {

- smoke_find_class(&c, kde_Smoke, "KCmdLineArgs");

- smoke_find_method(&m, kde_Smoke, c.index, "init$?#");

-

- stack[1].s_int = argc;

- stack[2].s_class = argv;

- stack[3].s_class = about;

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

-

- // app = new KApplication();

- void* app;

- {

- smoke_find_class(&c, kde_Smoke, "KApplication");

- smoke_find_method(&m, kde_Smoke, c.index, "KApplication");

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- app = stack[0].s_class;

-

- smoke_set_binding(c.smoke, kde, c.index, app);

- }

-

- {

- smoke_find_class(&c, kde_Smoke, "KGlobalSettings");

- smoke_find_method(&m, kde_Smoke, c.index, "Disable");

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

-

- // widget = new KXmlGuiWindow();

- // widget->setupGUI();

- // widget->show();

- // return app->exec();

- void* widget;

- {

- smoke_find_class(&c, kde_Smoke, "KXmlGuiWindow");

- smoke_find_method(&m, kde_Smoke, c.index, "KXmlGuiWindow");

-

- smoke_call_method(m.smoke, m.index, NULL, stack);

- widget = stack[0].s_class;

- smoke_set_binding(c.smoke, kde, c.index, widget);

-

- smoke_find_method(&m, c.smoke, c.index, "setupGUI");

- smoke_call_method(m.smoke, m.index, widget, stack);

-

- smoke_find_method(&m, c.smoke, c.index, "show");

- smoke_call_method(m.smoke, m.index, widget, stack);

-

- smoke_find_class(&c, kde_Smoke, "KApplication");

- smoke_find_method(&m, c.smoke, c.index, "exec");

- smoke_call_method(m.smoke, m.index, NULL, stack);

-

- return stack[0].s_int;

- }

-}

-add_subdirectory(examples)

+(defstruct smoke-array

+ (pointer (null-pointer) :type foreign-pointer)

+ (length 0 :type (smoke-index 0)))

+

+

+(defstruct smoke-module

+ (pointer (null-pointer) :type foreign-pointer)

+ (binding (null-pointer) :type foreign-pointer)

+

+ (classes (make-smoke-array) :type smoke-array)

+ (methods (make-smoke-array) :type smoke-array)

+ (method-maps (make-smoke-array) :type smoke-array)

+ (method-names (make-smoke-array) :type smoke-array)

+ (types (make-smoke-array) :type smoke-array)

+

+ (inheritance-list (null-pointer) :type foreign-pointer)

+ (argument-list (null-pointer) :type foreign-pointer)

+ (ambiguous-method-list (null-pointer) :type foreign-pointer))

+ [_$_]

+(defvar *smoke-modules* (make-hash-table))

+

+(defun init-smoke-module (module)

+ (let ((smoke (smoke-module-pointer module)))

+ (setf (gethash (pointer-address smoke) *smoke-modules*)

+ module)

+ (flet ((mk-array (array)

+ (make-smoke-array :pointer (cl-smoke-array smoke array)

+ :length (cl-smoke-array-size smoke array))))

+ (setf (smoke-module-classes module) (mk-array :classes)

+ (smoke-module-methods module) (mk-array :methods)

+ (smoke-module-method-maps module) (mk-array :method-maps)

+ (smoke-module-method-names module) (mk-array :method-names)

+ (smoke-module-types module) (mk-array :types)

+

+ (smoke-module-inheritance-list module)

+ (cl-smoke-array smoke :inheritance-list)

+

+ (smoke-module-argument-list module)

+ (cl-smoke-array smoke :argument-list)

+

+ (smoke-module-ambiguous-method-list module)

+ (cl-smoke-array smoke :ambiguous-method-list)))))

+

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

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

- smoke (smoke-get-module-name smoke))

+ smoke (smoke-get-module-name (smoke-module-pointer smoke)))

- (setf (gethash (pointer-address smoke) *smoke-id-class-map*)

+ (setf (gethash (pointer-address (smoke-module-pointer smoke)) *smoke-id-class-map*)

- "Convert camelCase to lisp-style."

+ "C++ namespace separator"

- ((smoke :reader smoke-symbol :initarg :smoke-symbol

- :type symbol))

+ ((pointer :type smoke-standard-class))

-(defmethod smoke ((class cxx:class))

- (eval (smoke-symbol class)))

-

+(defmethod pointer ((class cxx:class))

+ (pointer (slot-value class 'pointer)))

- :id (id superclass)

- :smoke (get-smoke-variable-for-pointer (smoke superclass))

+ :pointer superclass

+ :smoke (smoke superclass)

- :id (id superclass)

- :smoke (get-smoke-variable-for-pointer (smoke superclass))

+ :pointer superclass

+ :smoke (smoke superclass)

- (declare (foreign-pointer smoke)

- (optimize (speed 3)))

- (let ((*package* (find-package package)))

- (add-id-class-map smoke)

+ (declare (optimize (speed 3)))

+ (let ((*package* (find-package package)))

+ (add-id-class-map smoke)

- :id (id class)

+ :pointer [_$_]

+ (pointer class)

+ ;(mem-aref (smoke-array-pointer [_$_]

+ ; (smoke-module-classes

+ ; (smoke class)))

+ ; 'smoke-class

+ ; (id class))

+(declaim (inline smoke-class-of))

- (if (subtypep (class-of object) (find-class 'smoke-class))

+ (declare (optimize (speed 3)))

+ (if (typep object 'smoke-class)

- (declare (optimize (speed 3)))

+ (declare (dynamic-extent args)

+ (optimize (speed 3)))

- ((binding :pointer)

- (id smoke-index)

- (object-pointer :pointer))

- (declare (ignore binding id)

- (optimize (speed 3)))

+ ((object-pointer :pointer))

+ (declare (optimize (speed 3)))

+(declaim (inline argument-to-lisp))

+(defun argument-to-lisp (stack-item type)

+ ;; FIXME do not take ownership of stack allocated objects.

+ (type-to-lisp stack-item type))

+

- args

- (stack-to-args (cffi:inc-pointer stack

- (cffi:foreign-type-size 'smoke-stack-item))

+ (reverse args)

+ (stack-to-args (inc-pointer stack

+ (foreign-type-size 'smoke-stack-item))

- (append args (list

- (type-to-lisp (cffi:mem-ref stack 'smoke-stack-item)

- arg))))))

+ (push (argument-to-lisp (mem-ref stack

+ 'smoke-stack-item)

+ arg)

+ args))))

- (object :pointer)

+ (object-ptr :pointer)

- (let* ((method (make-instance 'smoke-method

- :id method

- :smoke (smoke-get-smoke binding))))

+ (let* ((method (make-smoke-method

+ :smoke (gethash (pointer-address (smoke-get-smoke binding))

+ *smoke-modules*)

+ :id method)))

+ (declare (function gf))

- (let ((object (get-object object)))

+ (let ((object (get-object object-ptr)))

+ ;; FIXME:

+ ;;(assert object

+ ;; (object)

+ ;; "No object for ~A to call ~A." object-ptr method)

- (put-returnvalue

- stack

- (apply gf object

- (stack-to-args

- (cffi:inc-pointer stack [_$_]

- (cffi:foreign-type-size

- 'smoke-stack-item))

- (get-first-argument method)))

- (return-type method)

- object)

- t)

+ (put-returnvalue stack

+ (apply gf object

+ (stack-to-args

+ (inc-pointer stack [_$_]

+ (foreign-type-size

+ 'smoke-stack-item))

+ (get-first-argument method)))

+ (return-type method)

+ object)

+ t)

+ ;; Restarts to prevent stack unwinding across the C++ stack.

+ (declare (stream stream))

+ (declare (stream stream))

- (get-object object))

+ (get-object object-ptr))

+ (declare (stream stream))

- (format stream "Try again calling ~A" [_$_]

+ (declare (stream stream))

+ (format stream "Try again calling ~A." [_$_]

- (smoke-cast (smoke (class-of object)) (pointer object)

+ (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object)

- (id (class-of object)) (class-id (smoke (class-of object))

- class)))

+ (id (class-of object)) (id class)))

- (smoke-cast (smoke class) (pointer object)

+ (smoke-cast (smoke-module-pointer (smoke class)) (pointer object)

+ (declare (optimize (speed 3)))

- (set-binding object (binding (smoke (class-of object))))

+ (set-binding object)

- (let ((ret (make-instance class

- :pointer pointer)))

+ (declare (type smoke-standard-class class)

+ (optimize (speed 3)))

+ (let ((ret (make-instance class :pointer pointer)))

- #-clisp

+ (declare (type smoke-standard-object object)

+ (optimize (speed 3)))

+(declaim (inline remove-wrapper-object))

+ (declare (optimize (speed 3)))

-(declaim (optimize (debug 3)))

- :smoke ',smoke))

+ :smoke ,smoke))

+(defmacro sizes= ((smoke)&rest arrays)

+ `(and ,@(loop for array in arrays collect

+ `(= (smoke-array-length (,array ,smoke))

+ ,(smoke-array-length (funcall (fdefinition array)

+ (eval smoke)))))))

+

- (unless (and (= (smoke-methods-size ,smoke)

- ,(smoke-methods-size (eval smoke)))

- (= (smoke-method-name-size ,smoke)

- ,(smoke-method-name-size (eval smoke)))

- (= (smoke-types-size ,smoke)

- ,(smoke-types-size (eval smoke)))

- (= (smoke-classes-size ,smoke)

- ,(smoke-classes-size (eval smoke))))

+ (unless (sizes= (,smoke)

+ smoke-module-methods

+ smoke-module-method-names

+ smoke-module-method-maps

+ smoke-module-classes

+ smoke-module-types)

- (smoke-get-module-name ,smoke)))))

+ (smoke-get-module-name (smoke-module-pointer ,smoke))))))

- (let ((method (make-instance 'smoke-method

- :id (abs id)

- :smoke (eval smoke))))

+ (let ((method (make-smoke-method

+ :smoke (eval smoke)

+ :id (abs id))))

-(declaim (inline ptr -address))

-(defun ptr-address (pointer)

- ;; CLISP returns NIL for a null pointer

- #+clisp

- (if pointer

- (pointer-address pointer)

- 0)

- #-clisp

- (pointer-address pointer))

-

- (gethash (ptr-address pointer) *object-map*))

+ (gethash (pointer-address pointer) *object-map*))

- (setf (gethash (ptr-address pointer) *object-map*)

+ (setf (gethash (pointer-address pointer) *object-map*)

+(declaim (inline has-pointer-p))

- (nth-value 1 (gethash (ptr-address pointer) *object-map*)))

+ (nth-value 1 (gethash (pointer-address pointer) *object-map*)))

- (remhash (ptr-address pointer) *object-map*))

+ (remhash (pointer-address pointer) *object-map*))

+ (declare (optimize (speed 3)))

- (remhash (ptr-address pointer) *object-map*))

+ (remhash (pointer-address pointer) *object-map*))

- function class pointer condition))

+ function class pointer condition)

+ #+sbcl (sb-debug:backtrace 10))

+ (declare (optimize (speed 3)))

-;;;

-;;; find-class

-;;; ensure-class

-;;; make-instance

-;;; class-name

-;;; class-slots

-;;; class-direct-subclasses

-;;; class-direct-superclasses

-;;; class-of

-;;; subclassp / subtypep

+(defclass smoke-class ()

+ ;; FXIME maybe change back to id

+ ((pointer :type foreign-pointer

+ :initarg :pointer

+ :reader pointer)

+ (smoke :type smoke-module

+ :initarg :smoke

+ :reader smoke))

+ (:documentation "A class"))

+(defun make-smoke-class-from-id (smoke id)

+ (make-instance 'smoke-class

+ :pointer (mem-aref (smoke-array-pointer (smoke-module-classes

+ smoke))

+ 'smoke-class

+ id)

+ :smoke smoke))

-(defclass smoke-class (smoke-symbol)

- ()

- (:documentation "A class"))

+(defmethod id ((class smoke-class))

+ (declare (values (smoke-index 0))

+ (optimize (speed 3)))

+ (values

+ (floor

+ (the (integer 0)

+ (- (pointer-address (pointer class))

+ (pointer-address (smoke-array-pointer (smoke-module-classes

+ (smoke class))))))

+ #.(cffi:foreign-type-size 'smoke-class))))

- (foreign-slot-value (smoke-get-class (smoke class) (id class))

+ (foreign-slot-value (pointer class)

+(define-compiler-macro class-slot-value (&whole form class slot-name)

+ (if (constantp slot-name)

+ `(foreign-slot-value (pointer ,class)

+ 'smoke-class ,slot-name)

+ form))

+

- (foreign-pointer smoke)

- :id 0

- (loop for id from 1 to (1- (the fixnum (smoke-classes-size smoke))) do

- (setf (slot-value class 'id) id)

+ (loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do

+ (setf (slot-value class 'pointer)

+ (mem-aref (smoke-array-pointer (smoke-module-classes smoke))

+ 'smoke-class

+ id))

+ (declare (optimize (speed 3)))

-(defmethod get-flag ((class smoke-class) flag)

- (boole boole-and (class-slot-value class 'flags)

- (foreign-enum-value 'smoke-class-flags flag)))

+(defun get-class-flag (class flag)

+ (declare (optimize (speed 3)))

+ (logand (class-slot-value class 'flags)

+ (the fixnum (foreign-enum-value 'smoke-class-flags flag))))

- (/= 0 (get-flag class :constructor)))

+ (/= 0 (get-class-flag class :constructor)))

- (/= 0 (get-flag class :virtual-destructor)))

+ (/= 0 (get-class-flag class :virtual-destructor)))

- (smoke-find-class c smoke name)

+ (smoke-find-class c (smoke-module-pointer smoke) name)

- (error (make-condition 'undefined-class :name name :smoke-name (smoke-get-module-name smoke)))

+ (error (make-condition 'undefined-class :name name :smoke-name (smoke-get-module-name (smoke-module-pointer smoke))))

- :id (foreign-slot-value c 'smoke-module-index 'index)

- :smoke (foreign-slot-value c 'smoke-module-index 'smoke))))

+ :pointer (smoke-get-class [_$_]

+ (foreign-slot-value c 'smoke-module-index 'smoke)

+ (foreign-slot-value c 'smoke-module-index 'index))

+ :smoke (gethash (pointer-address (foreign-slot-value c 'smoke-module-index 'smoke)) *smoke-modules*))))

- (smoke-is-derived-from (smoke class) (id class)

- (smoke base-class) (id base-class)))

+ (smoke-is-derived-from (smoke-module-pointer (smoke class)) (id class)

+ (smoke-module-pointer (smoke base-class)) (id base-class)))

- (let ((class-index (smoke-get-parent-index (smoke class) index)))

- (assert (< class-index (smoke-classes-size (smoke class))))

+ (let ((class-index (mem-aref (smoke-module-inheritance-list [_$_]

+ (smoke class))

+ 'smoke-index

+ index)))

+ (assert (<= class-index

+ (smoke-array-length

+ (smoke-module-classes (smoke class)))))

- (make-instance 'smoke-class

- :id class-index

- :smoke (smoke class))))

+ (make-smoke-class-from-id (smoke class)

+ class-index)))

-(defclass smoke-method (smoke-symbol)

- ()

- (:documentation "A C++ method"))

+(declaim (inline make-smoke-method))

+(defstruct smoke-method

+ (id 0 :type smoke-index)

+ (smoke (make-smoke-module) :type smoke-module))

+

+(declaim (inline smoke-method-pointer))

+(defun smoke-method-pointer (method)

+ (declare (optimize (speed 3)))

+ (mem-aref (smoke-array-pointer (smoke-module-methods

+ (smoke-method-smoke method)))

+ 'smoke-method

+ (smoke-method-id method)))

- (if (null-pointer-p (smoke smoke-method))

+ (if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method)))

+ (null-pointer-p (smoke-method-pointer smoke-method)))

+(defmethod smoke ((method smoke-method))

+ (smoke-module-pointer (smoke-method-smoke method)))

+

+(defmethod id ((method smoke-method))

+ (declare (optimize (speed 3)))

+ (smoke-method-id method))

+

-(defun valid-p (method)

- "Returns T when METHOD is valid and NIL otherwise."

- (/= 0 (id method)))

-

-(defun unambigous-p (method)

- "Returns T when METHOD is valid and not ambiguous."

- (< 0 (id method)))

-

-(defun ambiguous-p (method)

- "Returns T when METHOD is ambiguous and NIL otherwise."

- (> 0 (id method)))

-

-(defun make-smoke-method-munged (class munged-name-id)

- "Returns the method for the MUNGED-NAME-ID of SMOKE."

- (with-foreign-object (module 'smoke-module-index)

- (smoke-find-method-for-id module (smoke class) (id class) munged-name-id)

- (make-instance 'smoke-method

- :id (foreign-slot-value module 'smoke-module-index 'index)

- :smoke (foreign-slot-value module 'smoke-module-index 'smoke))))

-

- (smoke-find-method m (smoke class) (id class) name)

- (make-instance 'smoke-method

- :id (foreign-slot-value m 'smoke-module-index 'index)

- :smoke (foreign-slot-value m 'smoke-module-index 'smoke))))

+ (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)

+ (let ((smoke (foreign-slot-value m 'smoke-module-index 'smoke)))

+ (make-smoke-method

+ :smoke (if (null-pointer-p smoke)

+ (make-smoke-module)

+ (gethash (pointer-address smoke) *smoke-modules*))

+ :id (foreign-slot-value m 'smoke-module-index 'index)))))

-(defun make-smoke-method (class name)

+(defun make-smoke-method-from-name (class name)

- (smoke-find-method m (smoke class) (id class) name)

+ (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)

- (loop as i = (smoke-ambiguous-method (smoke class)

- (- (foreign-slot-value m 'smoke-module-index 'index)))

- while (> i 0)

+ (loop as i = (mem-aref (smoke-module-ambiguous-method-list (smoke class))

+ 'smoke-index

+ (- (foreign-slot-value m 'smoke-module-index 'index)))

+ while (> i 0)

- (let ((m (make-instance 'smoke-method :id i :smoke (smoke class))))

- (format t " ~A ~A~%" (name m) (signature m))))

- (error "The method ~S of ~S is ambigious" name (name class)));;TODO

- (make-instance 'smoke-method

- :id (foreign-slot-value m 'smoke-module-index 'index)

- :smoke (foreign-slot-value m 'smoke-module-index 'smoke))))

+ (let ((m (make-smoke-method :smoke (smoke class) :id i)))

+ (format t " ~A ~A~%" (name m) (signature m))))

+ (error "The method ~S of ~S is ambigious" name (name class))) ;;TODO

+ (make-smoke-method

+ :smoke (gethash (pointer-address

+ (foreign-slot-value m 'smoke-module-index 'smoke))

+ *smoke-modules*)

+ :id (foreign-slot-value m 'smoke-module-index 'index))))

- (cffi:foreign-pointer smoke)

- (let ((method (make-instance 'smoke-method

- :id 0

- :smoke smoke))

- (length (1- (the fixnum (smoke-methods-size smoke)))))

+ (let ((method (make-smoke-method :smoke smoke :id 0))

+ (length (smoke-array-length (smoke-module-methods smoke))))

- (setf (slot-value method 'id) id)

+ (setf (smoke-method-id method) id)

- (foreign-slot-value (smoke-get-method (smoke method) (id method))

+ (foreign-slot-value (smoke-method-pointer method)

+(define-compiler-macro method-slot-value (&whole form method slot-name)

+ "Optimize constant slot-names."

+ ;; declaring the function inline calls the compiler macro of

+ ;; foreign-slot-value with 'SLOT-NAME instead of its value an thus

+ ;; has no effect; thus the compiler macro.

+ (if (constantp slot-name)

+ `(foreign-slot-value (smoke-method-pointer ,method)

+ 'smoke-method ,slot-name)

+ form))

+ [_$_]

+

- (smoke-get-method-name (smoke method)

- (method-slot-value method 'name)))

+ (mem-aref (smoke-array-pointer (smoke-module-method-names

+ (smoke-method-smoke method)))

+ :string

+ (method-slot-value method 'name)))

- :smoke (smoke method)))

+ :smoke (smoke-method-smoke method)))

-(defmethod get-flag ((method smoke-method) flag)

+(defun get-method-flag (method flag)

+(define-compiler-macro get-method-flag (&whole form method flag)

+ (if (constantp flag)

+ `(logand (method-slot-value ,method 'flags)

+ ;; Resolve flag value at compile time

+ ,(foreign-enum-value 'smoke-method-flags flag)) [_$_]

+ form))

+

- (/= 0 (get-flag method :constructor)))

+ (/= 0 (get-method-flag method :constructor)))

- (/= 0 (get-flag method :destructor)))

+ (/= 0 (get-method-flag method :destructor)))

- (/= 0 (get-flag method :static)))

+ (/= 0 (get-method-flag method :static)))

- (/= 0 (get-flag method :protected)))

+ (/= 0 (get-method-flag method :protected)))

- (/= 0 (get-flag method :const)))

+ (/= 0 (get-method-flag method :const)))

+

+(defun valid-p (method)

+ "Returns T when METHOD is valid and NIL otherwise."

+ (/= 0 (smoke-method-id method)))

- (< 0 (id method)))

+ (< 0 (smoke-method-id method)))

- (/= 0 (get-flag method :enum)))

+ (/= 0 (get-method-flag method :enum)))

- (/= 0 (get-flag method :internal)))

+ (/= 0 (get-method-flag method :internal)))

- (make-instance 'smoke-class

- :id (method-slot-value method 'class)

- :smoke (smoke method)))

-

- [_$_]

+ (make-smoke-class-from-id

+ (smoke-method-smoke method)

+ (method-slot-value method 'class)))

- (smoke-get-argument (smoke argument) (slot-value argument 'id)))

+ (declare (optimize (speed 3)))

+ (mem-aref (smoke-module-argument-list (smoke argument))

+ 'smoke-index

+ (call-next-method)))

- (= 0 (smoke-get-argument (smoke argument) (1+ (slot-value argument 'id)))))

+ (= 0 (mem-aref (smoke-module-argument-list (smoke argument))

+ 'smoke-index

+ (1+ (slot-value argument 'id)))))

+ (declare (optimize (speed 3)))

- :smoke (smoke method)))

+ :smoke (smoke-method-smoke method)))

- :smoke (smoke method)))

+ :smoke (smoke-method-smoke method)))

-

-(defclass smoke-symbol ()

- ((id :reader id :initarg :id

- :type smoke-index

- :documentation "The objects index.")

- (smoke :reader smoke :initarg :smoke

- :initform (null-pointer)

- :documentation "Pointer to the Smoke module."))

- (:documentation "A method or class in a Smoke module."))

-

-(defmethod print-object ((smoke-symbol smoke-symbol) stream)

- (if (null-pointer-p (smoke smoke-symbol))

- (call-next-method)

- (print-unreadable-object (smoke-symbol stream :type t)

- (princ (name smoke-symbol) stream))))

-

-(defgeneric name (smoke-symbol)

- (:documentation "Returns the name of SMOKE-SYMBOL."))

-

-(defgeneric get-struct-slot-value (smoke-symbol slot-name)

- (:documentation "Returns the slot value of SLOT-NAME of

-the SMOKE-SYMBOLs struct."))

+ [_$_]

+(declaim (inline id))

+ (declare (optimize (speed 3)))

- (incf-pointer (top stack) (foreign-type-size 'smoke-stack-item)))

+ (incf-pointer (top stack) #.(foreign-type-size 'smoke-stack-item)))

+

+(define-compiler-macro push-stack (&whole form stack value type)

+ (if (constantp type)

+ `(progn [_$_]

+ (setf (foreign-slot-value (top ,stack)

+ 'smoke-stack-item ,type) ,value)

+ (incf-pointer (top ,stack) ,(foreign-type-size 'smoke-stack-item)))

+ form))

+ [_$_]

+ (declare (type (smoke-index 0) type-id)

+ (type call-stack stack)

+ (optimize (speed 3)))

+ (declare (optimize (speed 3)))

+ (declare (optimize (speed 3)))

+ (declare (optimize (speed 3)))

- (let ((object (object-to-lisp (foreign-slot-value stack-item

- 'smoke-stack-item

- 'class)

- type)))

- object))

+ (object-to-lisp (foreign-slot-value stack-item

+ 'smoke-stack-item

+ 'class)

+ type))

+ (declare (optimize (speed 3)))

-(defclass smoke-type (smoke-symbol)

- ()

+(declaim (inline smoke))

+

+(defclass smoke-type ()

+ ((id :reader id :initarg :id

+ :type smoke-index

+ :documentation "The objects index.")

+ (smoke :reader smoke :initarg :smoke

+ :type smoke-module

+ :documentation "Pointer to the Smoke module."))

-(defclass smoke-lazy-type (smoke::smoke-type)

- ((id :reader smoke::id

- :initarg :id)

- (smoke :initarg :smoke

- :reader smoke-symbol)))

+(defmethod print-object ((type smoke-type) stream)

+ (if (or (<= (id type) 0)

+ (null-pointer-p (smoke-module-pointer (smoke type))))

+ (call-next-method)

+ (print-unreadable-object (type stream :type t)

+ (princ (name type) stream))))

-(defmethod smoke::smoke ((type smoke-lazy-type))

- (eval (smoke-symbol type)))

+(defclass smoke-lazy-type (smoke-type)

+ ())

- (foreign-slot-value (smoke-get-type (smoke type) (id type))

+ (foreign-slot-value (mem-aref (smoke-array-pointer

+ (smoke-module-types (smoke type)))

+ 'smoke-type

+ (the smoke-index (id type)))

+(define-compiler-macro type-slot-value (&whole form type slot-name)

+ (if (constantp slot-name)

+ `(foreign-slot-value (mem-aref (smoke-array-pointer

+ (smoke-module-types (smoke ,type)))

+ 'smoke-type

+ (the smoke-index (id ,type)))

+ 'smoke-type ,slot-name)

+ form))

+ [_$_]

+

- :id (smoke-find-type smoke name)

+ :id (smoke-find-type (smoke-module-pointer smoke) name)

+ (declare (optimize (speed 3)))

-(defgeneric get-flag (object flag)

- (:documentation "Returns the value for FLAG of OBJECT."))

-

-(defmethod get-flag ((type smoke-type) flag)

+(defun get-type-flag (type flag)

+ (declare (optimize (speed 3)))

- #xF0 ;; = ! 0x0F

- (foreign-enum-value 'smoke-type-flags flag)))

+ #xF0 ;; = !0x0F

+ (the fixnum (foreign-enum-value 'smoke-type-flags flag))))

-(defun get-allocation-flag (type)

- (logand (type-slot-value type 'flags)

- #x30))

+(define-compiler-macro get-type-flag (&whole form type flag)

+ (if (constantp flag)

+ `(logand (type-slot-value ,type 'flags)

+ #xF0

+ ,(foreign-enum-value 'smoke-type-flags flag))

+ form))

+ [_$_]

+(defmacro allocation-flag-p (type flag)

+ ;; Can't just use #'get-type-flag since it

+ ;; can only be one of :stack, :reference and :pointer.

+ ;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30)

+ `(= ,(foreign-enum-value 'smoke-type-flags flag)

+ (logand #x30

+ (type-slot-value ,type 'flags))))

+(declaim (inline stack-p))

- (= (get-allocation-flag type) (get-flag type :stack)))

+ (allocation-flag-p type :stack))

- (= (get-allocation-flag type) (get-flag type :reference)))

+ (allocation-flag-p type :reference))

- (= (get-allocation-flag type) (get-flag type :pointer)))

+ (allocation-flag-p type :pointer))

- (/= 0 (get-flag type :const))))

+ (/= 0 (get-type-flag type :const))))

- (logand (type-slot-value type 'flags)

- (foreign-enum-value 'smoke-type-flags :type-id)))

+ (declare (smoke-type type)

+ (optimize (speed 3) (safety 0)))

+ (logand (the (c-integer :unsigned-short) (type-slot-value type 'flags))

+ #.(foreign-enum-value 'smoke-type-flags :type-id)))

- (= 0 (mem-ref (smoke-get-type (smoke type) (id type))

+ (= 0 (mem-ref (mem-aref (smoke-array-pointer

+ (smoke-module-types (smoke type)))

+ 'smoke-type

+ (id type))

- (make-instance 'smoke-class

- :id (type-slot-value type 'class)

- :smoke (smoke type)))

-

-

-;; FIXME why macro?

-(defmacro smoke-type-p (type smoke type-name)

- (let ((t2 (smoke-find-type smoke type-name)))

- `(and (= (id ,type) ,(id t2))

- (pointer-eq (smoke ,type) ,(smoke t2)))))

+ (make-smoke-class-from-id

+ (smoke type)

+ (type-slot-value type 'class)))

-(defun mung-char-p (character)

- "Returns true when CHARACTER is used for munging and false otherwise."

- (declare (character character))

- (case character

- ((#\$ #\? #\#) t)))

+(defun cstring= (string1 string2)

+ "Returns T when the C strings STRING1 and STRING2 are equal

+ and NIL otherwise."

+ (declare (optimize (speed 3) (safety 0)))

+ (dotimes (i array-total-size-limit)

+ (let ((char1 (mem-aref string1 :char i))

+ (char2 (mem-aref string2 :char i)))

+ (when (/= char1 char2)

+ (return-from cstring= nil))

+ (when (or (= 0 char1)

+ (= 0 char2))

+ (return-from cstring= (= char1 char2))))))

-(defun binary-search-method-names (name smoke start end)

- "Returns the index of NAME for the Smoke module SMOKE and 0 when

-NAME is not found."

- ;; FIXME search methods instead of methodMaps, since we are not

- ;; interrested in the munging.

- (declare ((smoke-index 1) start end)

- (string name)

+(declaim (inline cmp))

+(defun cmp (a b)

+ "Returns -1 if a < b; 0 if a = b and 1 if a > b"

+ (declare (values (integer -1 1)))

+ (if (< a b)

+ -1

+ (if (> a b)

+ 1

+ 0)))

+

+(declaim (inline cstring-cmp))

+(defun cstring-cmp (string1 string2)

+ "Compares the C strings STRING1 and STRING2."

+ (declare (foreign-pointer string1 string2)

+ (values (integer -1 1))

- (if (> start end)

- 0

- (let* ((index (floor (+ end start) 2))

- (method-name (smoke-get-method-name smoke index))

- (diff (string/= method-name name)))

- (if diff

- (if (and (>= diff (length name))

- (mung-char-p (char method-name diff)))

- index

- (if (and (< diff (length name))

- (or (>= diff (length method-name))

- (char< (char method-name diff) (char name diff))))

- (binary-search-method-names name smoke (1+ index) end)

- (binary-search-method-names name smoke start (1- index))))

- index))))

+ (dotimes (i array-total-size-limit (error "omg"))

+ (let ((char1 (mem-aref string1 :char i))

+ (char2 (mem-aref string2 :char i)))

+ (when (/= char1 char2)

+ (return-from cstring-cmp (if (< char1 char2) -1 1)))

+ (when (= 0 char1) ;; <=> (= 0 char2)

+ (return-from cstring-cmp 0)))))

-(defun method-name= (name munged)

- "Returns true when the name of the munged method name MUNGED is NAME."

- (let ((diff (string/= name munged)))

- (not (and diff

- (or (< diff (length name))

- (not (mung-char-p (char munged diff))))))))

+(defun cstring/= (string1 string2)

+ "Returns T when the C strings STRING1 and STRING2 are not equal

+ and NIL otherwise."

+ (declare (optimize (speed 3)))

+ (dotimes (i array-total-size-limit)

+ (let ((char1 (mem-aref string1 :char i))

+ (char2 (mem-aref string2 :char i)))

+ (when (/= char1 char2)

+ (return-from cstring/= i))

+ (when (= 0 char1)

+ (return-from cstring/= nil)))))

-(defun munged-method-argument-count (munged-name)

- "Returns the number of arguments the method MUNGED-NAME uses."

- (- (1- (length munged-name))

- (position-if-not #'mung-char-p munged-name :from-end t)))

- [_$_]

-(defun method-argument-count= (name munged-name argument-count)

- (declare ((integer 1 #.call-arguments-limit) argument-count))

- (and (= (length munged-name) (+ (length name) argument-count))

- (mung-char-p (char munged-name (length name)))))

+(declaim (inline smoke-method-name))

+(defun smoke-method-name (method)

+ (mem-aref (smoke-array-pointer (smoke-module-method-names [_$_]

+ (smoke-method-smoke method)))

+ :pointer

+ (the (smoke-index 0)

+ (method-slot-value method 'name))))

-(defun position-method-names (name argument-count smoke start end)

- "Returns a list of the method indices with name NAME

-that accept ARGUMENT-COUNT arguments."

- (declare (string name)

- ((smoke-index 1) start end)

+(defun method-cmp (method class-id name)

+ "Compares METHOD to the method with NAME of class CLASS-ID."

+ (declare (foreign-pointer name)

+ (type (smoke-index 0) class-id)

+ (smoke-method method)

+ (values (integer -1 1))

+ (optimize (speed 3) (debug 0) (safety 0)))

+ (let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))

+ (the (smoke-index 0) class-id))))

+ (declare (type (integer -1 1) id-cmp)

+ (dynamic-extent id-cmp))

+ (if (/= 0 id-cmp)

+ id-cmp

+ (cstring-cmp (smoke-method-name method)

+ name))))

+ [_$_]

+(defun first-unabigious-index (smoke index)

+ (declare (type smoke-index index)

- (let ((positions (loop for i from start to end

- while (method-name= name (smoke-get-method-name smoke i))

- when (method-argument-count= name (smoke-get-method-name smoke i)

- argument-count)

- collect i)))

- (loop for i from (1- start) downto 1

- while (method-name= name (smoke-get-method-name smoke i))

- do (when (method-argument-count= name (smoke-get-method-name smoke i)

- argument-count)

- (push i positions)))

- positions))

+ (if (>= index 0)

+ index

+ (mem-aref (smoke-module-ambiguous-method-list smoke)

+ 'smoke-index

+ (- index))))

-(defun smoke-modules (class)

- "Returns a list of super classes of CLASS; one or every smoke module

-that can be reached by super classes of CLASS. The returned super classes

-are as specific as possible."

- (let ((modules (list class)))

- (dolist (super-class (closer-mop:class-direct-superclasses class) modules)

- (when (and (typep super-class 'smoke-standard-class)

- (not (eql super-class (find-class 'smoke-standard-object))))

- (dolist (c (smoke-modules super-class))

- (setf modules (adjoin c modules :key #'smoke)))))))

+(defun find-method-for-class (name class)

+ "Returns the index of a method with name NAME for class CLASS."

+ (declare (type foreign-pointer name)

+ (type smoke-class class)

+ (optimize (speed 3)))

+ (let* ((start 1) ;; 0 is "no method"

+ (class-id (id class))

+ (smoke (smoke class))

+ (end (smoke-array-length (smoke-module-method-maps smoke))))

+ (declare (type (smoke-index 0) start end))

+ (loop until (> start end) do

+ (let* ((index (the smoke-index (floor (+ end start) 2)))

+ (method (make-smoke-method [_$_]

+ :smoke smoke [_$_]

+ :id (the (smoke-index 0)

+ (first-unabigious-index

+ smoke

+ (foreign-slot-value

+ (mem-aref (smoke-array-pointer

+ (smoke-module-method-maps

+ smoke))

+ 'smoke-method-map index)

+ 'smoke-method-map

+ 'method)))))

+ (cmp (the (integer -1 1) (method-cmp method class-id name))))

+ (declare (type (integer -1 1) cmp)

+ (dynamic-extent method index cmp))

+ (ecase cmp

+ (-1 (setf start (1+ index)))

+ (0 (return-from find-method-for-class index))

+ (1 (setf end (1- index)))))))

+ -1)

+(defmacro push-candidate-method (index name argument-count class methods)

+ (with-gensyms (method-map method-index method ambig-index i smoke)

+ `(let* ((,smoke (smoke ,class))

+ (,method-map (mem-aref

+ (smoke-array-pointer

+ (smoke-module-method-maps ,smoke))

+ 'smoke-method-map

+ ,index))

+ (,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))

+ (,method (make-smoke-method

+ :smoke ,smoke

+ :id (first-unabigious-index

+ ,smoke

+ ,method-index))))

+ (declare (type smoke-index ,method-index))

+ (if (cstring/= ,name

+ (smoke-method-name ,method))

+ nil

+ (progn

+ (when (= (the smoke-index ,argument-count)

+ (the smoke-index (get-arguments-length ,method)))

+ (if (< ,method-index 0)

+ (let ((,ambig-index (- ,method-index)))

+ (declare (type smoke-index ,ambig-index))

+ (loop as ,i = (the smoke-index

+ (mem-aref (smoke-module-ambiguous-method-list

+ ,smoke)

+ 'smoke-index

+ ,ambig-index))

+ while (> (the smoke-index ,i) 0) do

+ (incf ,ambig-index)

+ (push (make-smoke-method :smoke ,smoke

+ :id ,i)

+ ,methods)))

+ (push ,method ,methods))) [_$_]

+ t)))))

-(defun viable-functions (name argument-count class2)

+(defun all-smoke-superclasses (class)

+ "Returns a list of all superclasses of CLASS and CLASS itself."

+ (declare (optimize (speed 3)))

+ (let ((classes (list class)))

+ (dolist (class (closer-mop:class-direct-superclasses class) classes)

+ (when (typep class 'smoke-standard-class)

+ (setf classes (append (all-smoke-superclasses class) classes))))))

+ [_$_]

+(defun viable-functions (name argument-count class)

- (let ((methods))

- (dolist (class (smoke-modules class2))

- (let ((index (binary-search-method-names

- name (smoke class) 1

- (smoke-method-name-size (smoke class)))))

- (loop for i in (position-method-names name argument-count (smoke class)

- index

- (smoke-method-name-size [_$_]

- (smoke class)))

- do [_$_]

- (let ((method (make-smoke-method-munged class i)))

- (if (unambigous-p method)

- (push method methods)

- (when (ambiguous-p method)

- (let ((index (- (id method))))

- (loop as i = (smoke-ambiguous-method (smoke method)

- index)

- while (> i 0) do

- (incf index)

- (push (make-instance 'smoke-method

- :smoke (smoke method)

- :id i)

- methods)))))))))

- methods))

- [_$_]

+ ;; FIXME make a lazy map-viable-functions to allow returning early,

+ ;; when an exact match is found.

+ (declare (optimize (speed 3)))

+ (with-foreign-string (name name)

+ (let ((methods)

+ (smoke (smoke class)))

+ (dolist (class (all-smoke-superclasses class))

+ (let ((start-index (find-method-for-class name class)))

+ (declare (type smoke-index start-index))

+ (loop for index from start-index downto 1

+ while (push-candidate-method index name argument-count class

+ methods))

+ (loop for index from (1+ start-index)

+ to (the smoke-index (smoke-array-length

+ (smoke-module-method-maps smoke)))

+ while (push-candidate-method index name argument-count class

+ methods))))

+ methods)))

+ [_$_]

+ (declare (optimize (speed 3)))

- (< (rank conversion1) (rank conversion2))))

+ (< (the fixnum (rank conversion1))

+ (the fixnum (rank conversion2)))))

+ (declare (optimize (speed 3)))

+ ;; FIXME test for ambigious overload #'conversion=

-(defmacro string-case ((keyform) &body clauses)

- ;; FIXME this is horribly inefficient

- `(cond ,@(mapcar #'(lambda (clause)

- `((string= ,keyform ,(first clause))

- ,@(rest clause)))

- clauses)))

-

-(defmacro smoke-type-case ((keyform class) &body clauses)

- `(string-case ((name ,keyform))

- ,@(mapcar (curry #'apply

- #'(lambda (type-name lisp-type)

- `(,type-name (typep-using-type ,class (quote ,lisp-type)))))

- clauses)))

-

- (0 [_$_]

- (when-let (test (gethash (name type) *from-lisp-translations*))

- (funcall test (object.type-of))))

+ (0 (when-let (test (gethash (name type) *from-lisp-translations*))

+ (funcall test (object.type-of))))

+ "Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."

- (assert (valid-p method)

- ()

- "No applicable method ~A() for ~A." name object-or-class)

+ (unless (valid-p method)

+ (error (make-condition 'no-applicable-cxx-method

+ :method name

+ :class object-or-class

+ :arguments arguments)))

- #:new-object

-/** @brief Common Lisp smoke binding namespace. */

+/** @brief Common Lisp Smoke binding namespace. */

+/** The arrays of the Smoke module */

+enum cl_smoke_module_array

+{

+ classes,

+ methods,

+ method_maps,

+ method_names,

+ types,

+ inheritance_list,

+ argument_list,

+ ambiguous_method_list

+};

+

-(defcfun smoke-classes-size smoke-index

- (smoke :pointer))

-

-(defcfun smoke-get-parent-index smoke-index

- (smoke :pointer)

- (class smoke-index))

-

- * @param binding Smoke binding of the object

- * @param class_id class id

- * @param object the object

+ * @param object pointer to the object

- *when the default method shall be invoked.

+ * when the default method shall be invoked.

-Binding::deleted(Smoke::Index classId, void *obj)

+Binding::deleted(Smoke::Index, void *object)

- destruct(this, classId, obj);

+ destruct(object);

- typedef void (*destructed)(Binding* binding, Smoke::Index class_id,

- void* object);

+ typedef void (*destructed)(void* object);

- deleted(Smoke::Index classId, void *obj);

+ deleted(Smoke::Index classId, void *object);

-(declaim (optimize (debug 3)))

-

-(defcfun smoke-get-method-map (:pointer smoke-method-map)

- (smoke :pointer)

- (index smoke-index))

-

-(defcfun smoke-find-method-for-id :void

- (m :pointer smoke-module-index)

- (smoke :pointer)

- (class-index smoke-index)

- (method-name smoke-index))

-

+(declaim (inline smoke-find-method))

-

-(defcfun smoke-methods-size smoke-index

- (smoke :pointer))

-

-(defcfun smoke-get-method (:pointer smoke-method)

- (smoke :pointer)

- (method smoke-index))

-

-(defcfun smoke-get-method-name :string

- (smoke :pointer)

- (method-index smoke-index))

-

-(defcfun smoke-method-name-size smoke-index

- (smoke :pointer))

-

-(defcfun smoke-call-method :void

- (smoke :pointer)

- (method smoke-index)

- (object :pointer)

- (stack smoke-stack))

-

-(defcfun smoke-get-argument smoke-index

- (smoke :pointer)

- (argument smoke-index))

-

-(defcfun smoke-ambiguous-method smoke-index

- (smoke :pointer)

- (ambiguous smoke-index))

- *

- * @example examples/kde-hello-world.cpp

- * This KDE example creates a KXmlGuiWindow.

- * Note that C++ is only used to make the example shorter

- * (by allowing to directly include smoke-c.cpp), but it could also

- * be implemented in C using \c dlsym.

- *

- * @image html doc/images/kde-hello-world.png "Screenshot"

- * @image latex doc/images/kde-hello-world.png "Screenshot" width=5cm

+

+/** Returns the pointer to the array @a array of @a smoke.

+ * @param smoke the Smoke module

+ * @param array the array type

+ * [_$_]

+ * @return a pointer to the array

+ */

+CL_SMOKE_EXPORT void*

+cl_smoke_array(void* smoke, cl_smoke_module_array array)

+{

+ switch (array)

+ {

+ case classes:

+ return get_smoke(smoke)->classes;

+ case methods:

+ return get_smoke(smoke)->methods;

+ case method_maps:

+ return get_smoke(smoke)->methodMaps;

+ case method_names:

+ return get_smoke(smoke)->methodNames;

+ case types:

+ return get_smoke(smoke)->types;

+ case inheritance_list:

+ return get_smoke(smoke)->inheritanceList;

+ case argument_list:

+ return get_smoke(smoke)->argumentList;

+ case ambiguous_method_list:

+ return get_smoke(smoke)->ambiguousMethodList;

+ }

+ qFatal("cl_smoke_array(): Unknown smoke_array %d", array);

+}

+

+/** Returns the size of the array @a array of @a smoke.

+ * The size if inclusive the bound.

+ * @param smoke the Smoke module

+ * @param array the array type

+ *

+ * @return the size

+ */

+CL_SMOKE_EXPORT Smoke::Index

+cl_smoke_array_size(void* smoke, cl_smoke_module_array array)

+{

+ switch (array)

+ {

+ case classes:

+ return get_smoke(smoke)->numClasses;

+ case methods:

+ return get_smoke(smoke)->numMethods;

+ case method_maps:

+ return get_smoke(smoke)->numMethodMaps;

+ case method_names:

+ return get_smoke(smoke)->numMethodNames;

+ case types:

+ return get_smoke(smoke)->numTypes;

+ case inheritance_list:

+ case argument_list:

+ case ambiguous_method_list:

+ qFatal("cl_smoke_array_size(): size of %d not known.", array);

+ }

+ qFatal("cl_smoke_array_size(): Unknown smoke_array %d.", array);

+}

+

-

-

-/** Gets the number of classes.

- *

- * @return the number of classes

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_classes_size(void* smoke)

-{

- return get_smoke(smoke)->numClasses;

-}

-

-/** Sets the binding for an newly constructed instance.

- * @param smoke the Smoke module

- * @param binding the Smoke binding

- * @param class_index the index of the instances class

- * @param object pointer to the class instance.

- */

-CL_SMOKE_EXPORT void

-smoke_set_binding(void* smoke, smoke_binding binding, Smoke::Index class_index, void* object)

-{

- Q_ASSERT(object != NULL);

- Q_ASSERT(binding != NULL);

- Q_ASSERT(class_index > 0 && class_index <= smoke_classes_size(smoke));

-

- const Smoke::Class* klass = &get_smoke(smoke)->classes[class_index];[_^I_][_$_]

-

- Smoke::StackItem stack[2];

- stack[1].s_voidp = get_smoke_binding(binding);

-

- (*klass->classFn)(0, object, stack);

-}

-

- Q_ASSERT(class_index >= 0 && class_index <= smoke_classes_size(smoke));

+ Q_ASSERT(class_index >= 0 && class_index <= get_smoke(smoke)->numClasses);

-/** Returns the index of a base class.

- * @param smoke the Smoke module

- * @param class_index the class index

- * [_$_]

- * @return the index of a parent

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_get_parent_index(void* smoke, Smoke::Index class_index)

-{

- Q_ASSERT(class_index >= 0);

-

- return get_smoke(smoke)->inheritanceList[class_index];

-}

-

-/** Gets the method map.

- * @param smoke the Smoke module

- * @param method the index of the method

- *

- * @return a pointer to the @c MethodMap entry.

- */

-CL_SMOKE_EXPORT const Smoke::MethodMap*

-smoke_get_method_map(void* smoke, Smoke::Index method)

-{

- Q_ASSERT(method >= 0 && method <= get_smoke(smoke)->numMethodMaps);

-

- return &get_smoke(smoke)->methodMaps[method];

-}

-

-/** Gets a methods name.

- * @param smoke the Smoke module

- * @param method_name the method name index

- *

- * @return the method name

- */

-CL_SMOKE_EXPORT const char*

-smoke_get_method_name(void* smoke, Smoke::Index method_name)

-{

- Q_ASSERT(method_name >= 0 && method_name <= get_smoke(smoke)->numMethodNames);

-

- return get_smoke(smoke)->methodNames[method_name];

-}

-

-/** Gets the number of method names.

- * @param smoke the Smoke module

- *

- * @return the number of method names

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_method_name_size(void *smoke)

-{

- return get_smoke(smoke)->numMethodNames;

-}

-

-/** Gets the number of methods.

- * @param smoke the Smoke module

- *

- * @return the number of methods

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_methods_size(void* smoke)

-{

- return get_smoke(smoke)->numMethods;

-}

-

-/** Gets a method.

- * @param smoke the smoke binding

- * @param method the index of the method

- *

- * @return a pointer to the method struct

- */

-CL_SMOKE_EXPORT const struct Smoke::Method*

-smoke_get_method(void* smoke, Smoke::Index method)

-{

- Q_ASSERT(method >= 0 && method <= smoke_methods_size(smoke));

-

- return &get_smoke(smoke)->methods[method];

-}

-

- m->index = smoke_get_method_map(m->smoke, m->index)->method;

-}

-

-/** Finds a method for a class and a munged name.

- * @param m pointer where the result is stored.

- * @param smoke the Smoke binding

- * @param class_index index of the class

- * @param method_name index of the munged method name

- */

-CL_SMOKE_EXPORT void

-smoke_find_method_for_id(Smoke::ModuleIndex* m, void* smoke,

- Smoke::Index class_index, Smoke::Index method_name)

-{

- *m = get_smoke(smoke)->findMethod((Smoke::ModuleIndex){get_smoke(smoke), class_index},

- (Smoke::ModuleIndex){get_smoke(smoke), method_name});

-

- if(m->index > 0)

- m->index = smoke_get_method_map(m->smoke, m->index)->method;

-}

-

-/** Gets the type index of an argument.

- * @param smoke the smoke binding

- * @param argument the argument index

- *

- * @return the type index

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_get_argument(void* smoke, Smoke::Index argument)

-{

- Q_ASSERT(argument >= 0);

-

- return get_smoke(smoke)->argumentList[argument];

-}

-

-/** Calls a method.

- * The methods return value is stored in the first element of the stack.

- * @param smoke the smoke binding

- * @param method the index of the method

- * @param object A pointer to the class instance, or NULL for static and constructor calls

- * @param stack The stack with the methods arguments.

- */

-CL_SMOKE_EXPORT void

-smoke_call_method(void* smoke, Smoke::Index method, void* object,

- Smoke::Stack stack)

-{

- Smoke::Method meth = *smoke_get_method(smoke, method);

- Q_ASSERT(!(meth.flags & Smoke::mf_internal));

- Q_ASSERT_X((NULL == object

- && (meth.flags & (Smoke::mf_static

- | Smoke::mf_enum

- | Smoke::mf_copyctor

- | Smoke::mf_ctor)))

- || object,

- __func__, "object is NULL");

- Q_ASSERT(meth.flags & Smoke::mf_ctor ? NULL == object : true);

- const Smoke::Class* klass = smoke_get_class(smoke, meth.classId);

-

- try

- {

- Q_ASSERT(klass->classFn != NULL);

- (*klass->classFn)(meth.method, object, stack);

- } [_$_]

- // This catch is mostly useless:

- // Qt / KDElibs do not use exceptions and since they are often built with -fno-exceptions

- // the catch will have no effect and the terminate handler is called instead.

- catch (const std::exception& e) [_$_]

- {

- qFatal(e.what());

- }

- catch (...)

- {

- qFatal("exception in C++ code.");

- }

+ m->index = m->smoke->methodMaps[m->index].method;

-/** Gets the number of types.

- * @param smoke the Smoke module

- *

- * @return the number of types

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_types_size(void* smoke)

-{

- return get_smoke(smoke)->numTypes;

-}

-

-/** Gets a type.

- * @param smoke the Smoke module

- * @param type the index of the type

- *

- * @return a pointer to the type struct

- */

-CL_SMOKE_EXPORT const struct Smoke::Type*

-smoke_get_type(void* smoke, Smoke::Index type)

-{

- Q_ASSERT(type >= 0 && type <= smoke_types_size(smoke));

-

- return &get_smoke(smoke)->types[type];

-}

-

- Q_ASSERT(from > 0 && from <= smoke_classes_size(smoke));

- Q_ASSERT(to > 0 && to <= smoke_classes_size(smoke));

+ Q_ASSERT(from > 0 && from <= get_smoke(smoke)->numClasses);

+ Q_ASSERT(to > 0 && to <= get_smoke(smoke)->numClasses);

-/** Gets an ambiguous method.

- * @param smoke the Smoke module

- * @param ambiguous the index

- *

- * @return the index of a method

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_ambiguous_method(void* smoke, Smoke::Index ambiguous)

-{

- Q_ASSERT(ambiguous >= 0);

-

- return get_smoke(smoke)->ambiguousMethodList[ambiguous];

-}

-

-(defcfun smoke-set-binding :void

- "Sets the binding for an newly constructed instance."

- (smoke :pointer)

- (smoke-binding smoke-binding)

- (class smoke-index)

- (object :pointer))

-

+(declaim (inline smoke-get-smoke))

+

+(defcenum cl-smoke-array

+ :classes

+ :methods

+ :method-maps

+ :method-names

+ :types

+ :inheritance-list

+ :argument-list

+ :ambiguous-method-list)

+

+(defcfun cl-smoke-array :pointer

+ (smoke :pointer)

+ (array cl-smoke-array))

+

+(defcfun cl-smoke-array-size smoke-index

+ (smoke :pointer)

+ (array cl-smoke-array))

- "A type"

-

-(defcfun smoke-types-size smoke-index

- (smoke :pointer))

-

-(defcfun smoke-get-type (:pointer smoke-type)

- (smoke :pointer)

- (type smoke-index))

-(defun s-call (method object &optional (args nil))

+(declaim (inline call-s-method) (optimize (debug 3)))

+(defun call-s-method (method object-pointer stack-pointer)

+ (foreign-funcall-pointer [_$_]

+ (foreign-slot-value (pointer (get-class method))

+ 'smoke-class

+ 'class-function)

+ ()

+ smoke-index (foreign-slot-value (smoke-method-pointer method)

+ 'smoke-method

+ 'method)

+ :pointer object-pointer

+ smoke-stack stack-pointer

+ :void))

+

+(defun s-call (method object-pointer &optional (args nil))

- (smoke-call-method (smoke method) (id method)

- object (pointer stack))

+ (call-s-method method object-pointer (pointer stack))

-(defun pointer-call (method object &optional (args nil))

+(defun pointer-call (method object-pointer &optional (args nil))

- (smoke-call-method (smoke method) (id method)

- object (pointer stack))

+ (call-s-method method object-pointer (pointer stack))

- (make-smoke-method class method-name)

+ (make-smoke-method-from-name class method-name)

- (make-smoke-method (make-smoke-class smoke class-name)

- method-name)

+ (make-smoke-method-from-name (make-smoke-class smoke class-name)

+ method-name)

- (smoke-call-method (smoke method) (id method)

- (null-pointer) (pointer stack))

+ (call-s-method method (null-pointer) (pointer stack))

-(defun new-object (binding class-name method-name &rest args)

- (let* ((smoke (smoke-get-smoke binding))

- (method (make-smoke-method (make-smoke-class smoke class-name)

- method-name))

- (pointer

- (pointer-call method (null-pointer) args))

- (object (instance-to-lisp pointer [_$_]

- (find-smoke-class (get-class (return-type method)))

- (return-type method))))

- (set-binding object (binding (smoke (class-of object))))

- (add-object object)

- object))

- [_$_]

-

+; (declare (optimize (speed 3)))

- (make-smoke-method class method-name)

+ (make-smoke-method-from-name class method-name)

- (make-smoke-method (class-of object) method-name)

+ (make-smoke-method-from-name (class-of object) method-name)

-(defun set-binding (object binding)

- (smoke-set-binding (smoke (class-of object)) binding (id (class-of object)) (pointer object)))

+(defun set-binding (object)

+ "Sets the Smoke binding for OBJECT, that receives its callbacks."

+ (declare (optimize (speed 3)))

+ (with-foreign-object (stack 'smoke-stack-item 2)

+ (setf (foreign-slot-value (mem-aref stack

+ 'smoke-stack-item

+ 1)

+ 'smoke-stack-item

+ 'voidp)

+ (smoke-module-binding (smoke (class-of object))))

+ (foreign-funcall-pointer [_$_]

+ (foreign-slot-value (pointer (class-of object))

+ 'smoke-class

+ 'class-function)

+ ()

+ smoke-index 0 ;; set binding method index

+ :pointer (pointer object) smoke-stack stack

+ :void)))

-(defun init (smoke)

+(defun init (smoke module)

- (let ((binding (smoke-init smoke

- (callback destructed)

- (callback dispatch-method))))

- (setf (binding smoke) binding)

- binding))

+ (let* ((binding (smoke-init smoke

+ (callback destructed)

+ (callback dispatch-method))))

+ (setf (binding smoke) binding

+ (smoke-module-pointer module) smoke

+ (smoke-module-binding module) binding)

+ (init-smoke-module module)

+ (setf (gethash (pointer-address smoke) *smoke-modules*) module)

+ module))

- (setf (gethash (pointer-address (eval symbol)) pointer-symbol-map)

+ (setf (gethash (pointer-address (smoke-module-pointer (eval symbol))) pointer-symbol-map)

- (maphash #'(lambda (address value)

- (declare (ignore value))

- (let ((smoke (make-pointer address)))

- (map-methods #'(lambda (method)

- (when (and (string= name (name method))

- (not (enum-p method)))

- (push (make-instance 'smoke-method

- :id (id method)

- :smoke (smoke method))

- methods)))

- smoke)))

- *smoke-id-class-map*)

+ (maphash

+ #'(lambda (address value)

+ (declare (ignore value))

+ (let ((smoke (make-pointer address)))

+ (map-methods #'(lambda (method)

+ (when (and (string= name (name method))

+ (not (enum-p method)))

+ (push (make-instance 'smoke-method

+ :id (smoke-method-id method)

+ :smoke (smoke method))

+ methods)))

+ smoke)))

+ *smoke-id-class-map*)

- (when (search str (name method))

- (format t "~A::~A~%" (name (get-class method))

- (signature method))))

+ (when (search str (name method))

+ (princ (method-declaration method))

+ (terpri)))

- `(progn

- (eval-startup (:compile-toplevel :execute)

+ (let ((smoke-module (intern "*SMOKE-MODULE*")))

+ `(progn

+ (eval-startup (:compile-toplevel :execute)

+ (eval-when (:compile-toplevel :load-toplevel :execute)

+ (define-foreign-library ,library

+ (:unix ,(format nil "~(~A~).so.2" library))

+ (t (:default ,(format nil "~(~A~)" library))))

+ (use-foreign-library ,library))

+ (defcvar (,variable ,variable-name :read-only t) :pointer)

+ (defcfun (,init-function ,(format nil "_Z~A~Av"

+ (length function-name)

+ function-name))

+ :void))

- (define-foreign-library ,library

- (:unix ,(format nil "~(~A~).so.2" library))

- (t (:default ,(format nil "~(~A~)" library))))

- (use-foreign-library ,library))

- (defcvar (,variable ,variable-name :read-only t) :pointer)

- (defcfun (,init-function ,(format nil "_Z~A~Av" (length function-name)

- function-name))

- :void))

- (eval-startup (:compile-toplevel :execute)

- (,init-function)

- (init ,variable))

- (define-classes-and-gfs ,package ,variable)))

+ (defparameter ,smoke-module (make-smoke-module)))

+ (eval-startup (:compile-toplevel :execute)

+ (,init-function)

+ (init ,variable ,smoke-module))

+ (define-classes-and-gfs ,package ,smoke-module))))

+;;; NOTE -using-type is disabled for now, since it is not used.

+

-false when it is not"; and :MAYBE when the relationship

-;could not be determined."

+false when it is not; and :MAYBE when the relationship

+could not be determined."

+ #+nil [_$_]

+ #+nil

-sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@" || exit 1

+MALLOC_CHECK_=3 sbcl --noinform --disable-debugger --noprint --load $0 --end-toplevel-options "$@" || exit 1

-(mb:clean :smoke)

+;(mb:load :FiveAm)

+;(setf 5am:*debug-on-failure* t)

+;(setf 5am:*debug-on-error* t)

Fri Jun 12 14:21:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Load Smoke libraries at compile time.

-(defclass smoke-standard-object ()

- ((pointer :reader pointer

- :initarg :pointer

- :documentation "Pointer to the C++ object.")

- ;; We can not have a global table of objects owned by C++,

- ;; since then they would be alway reacable from Lisp and thus

- ;; cycles would never be garbage collected.

- (owned-objects :accessor owned-objects

- :initform nil

- :type list

- :documentation "Objecsts owned by the C++ instance."))

- (:documentation "The standard superclass for Smoke classes."))

-

+

+(defclass smoke-standard-object ()

+ ((pointer :reader pointer

+ :initarg :pointer

+ :documentation "Pointer to the C++ object.")

+ ;; We can not have a global table of objects owned by C++,

+ ;; since then they would be alway reacable from Lisp and thus

+ ;; cycles would never be garbage collected.

+ (owned-objects :accessor owned-objects

+ :initform nil

+ :type list

+ :documentation "Objecsts owned by the C++ instance."))

+ (:documentation "The standard superclass for Smoke classes."))

+ (eval-when (:compile-toplevel :load-toplevel :execute)

- (use-foreign-library ,library)

+ (use-foreign-library ,library))

Thu Jun 11 20:45:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* futile CLISP fixes

+ #-clisp

- #-cmucl (make-weak-hash-table :weakness weakness)

+ #-cmucl (make-weak-hash-table :weakness #-clisp weakness

+ ;; CLISP crash with weak hash table

+ ;; leak memory (see also: #'keep-wrapper)

+ #+clisp nil)

+

+;; FIXME

+;; CLISP has problems with weak hashtables and finalizers.

+;; trivial-garbage has a workaround!?

+;; http://sourceforge.net/tracker/index.php?func=detail&aid=1472478&group_id=1355&atid=101355

+;; crashes 2.47 and 2.44.1

+;; Works when not using a weak hash table, but now we are leaking memory!

+(declaim (inline ptr -address))

+(defun ptr-address (pointer)

+ ;; CLISP returns NIL for a null pointer

+ #+clisp

+ (if pointer

+ (pointer-address pointer)

+ 0)

+ #-clisp

+ (pointer-address pointer))

+

- (gethash (pointer-address pointer) *object-map*))

+ (gethash (ptr-address pointer) *object-map*))

- (setf (gethash (pointer-address pointer) *object-map*)

+ (setf (gethash (ptr-address pointer) *object-map*)

- (nth-value 1 (gethash (pointer-address pointer) *object-map*)))

+ (nth-value 1 (gethash (ptr-address pointer) *object-map*)))

- (remhash (pointer-address pointer) *object-map*))

+ (remhash (ptr-address pointer) *object-map*))

- (remhash (pointer-address pointer) *object-map*))

+ (remhash (ptr-address pointer) *object-map*))

Thu Jun 11 16:35:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Modules can specify the package to place the classes, static methods and constants in.

- ())

+ ((package :initarg :package)))

-(defun make-smoke-classes (smoke)

- "Construts a lisp class for each one in the Smoke module SMOKE."

+(defun make-smoke-classes (package smoke)

+ "Construts a lisp class in PACKAGE for each one in the Smoke module SMOKE."

+ (let ((*package* (find-package package)))

- smoke))

+ smoke)))

-(defun constant-definition (method smoke)

+(defun constant-definition (package method smoke)

- "+"))

+ "+")

+ package)

- (name method) "+")))))

+ (name method) "+")

+ package))))

-(defun static-method-symbol (method)

+(defun static-method-symbol (package method)

- (name method)))))

+ (name method))

+ package)))

-(defun static-method-definition (method &optional (argument-count -1))

+(defun static-method-definition (package method &optional (argument-count -1))

- (name (static-method-symbol method)))

+ (name (static-method-symbol package method)))

- (call-using-args (find-class (quote ,(lispify (name class))))

+ (call-using-args (find-class (quote ,(lispify (name class) package)))

-(defmacro define-methods (smoke)

+(defmacro define-classes-and-gfs (package smoke)

- (multiple-value-bind (def export) (constant-definition method smoke)

+ (multiple-value-bind (def export) (constant-definition package method smoke)

- (let* ((function-symbol (static-method-symbol method))

+ (let* ((function-symbol (static-method-symbol package method))

+ package

- (make-smoke-classes ,smoke)

+ (make-smoke-classes ,package ,smoke)

- (export (quote ,exports))))))

+ (export (quote ,exports) ,package)))))

- "asdf"

-(defmacro define-smoke-module (library (variable variable-name)

+(defmacro define-smoke-module (package library [_$_]

+ (variable variable-name)

- (define-methods ,variable)))

+ (define-classes-and-gfs ,package ,variable)))

Wed Jun 10 14:01:10 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* No need for a synchronized hash table when threads are not supported.

- (cerror "Use unsynchronized hash-table"

- "Synchronized hash table not implemented.")

+ (when *supports-threads-p*

+ (cerror "Use unsynchronized hash-table"

+ "Synchronized hash table not implemented."))

Wed Jun 10 13:55:55 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix ownership transfer for non cxx:class objects.

+ (assert (virtual-destructor-p superclass)

+ ()

+ "The class ~A has a non virtual destructor." superclass)

+ [_$_]

- (transfer-ownership-to value object))))))

+ (when (typep value 'smoke-standard-object)

+ (transfer-ownership-to value object)))))))

- (assert (not (member object (owned-objects new-owner)))

- ()

- "~A has already been called for ~A." #'keep-wrapper object)

+ (when (member object (owned-objects new-owner))

+ (cerror "ignore" "~A has already been called for ~A."

+ #'keep-wrapper object))

- (if (typep (class-of object) 'cxx:class)

- (progn

- (assert (virtual-destructor-p (class-of object))

- ()

- "The ownership of the object ~A is transfered to C++, but

-it has a nonvirtual destructor." object)

- (keep-wrapper object new-owner))

- (when (and (typep object 'smoke-standard-object)

- (not (virtual-destructor-p (class-of object))))

- (remove-object (pointer object)))))

+ (if (virtual-destructor-p (class-of object))

+ (keep-wrapper object new-owner)

+ (remove-object (pointer object))))

-

Mon Jun 8 11:20:54 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Make unreadable cycles garbage collectable.

- ((pointer :reader pointer :initarg :pointer

- :documentation "Pointer to the C++ object."))

+ ((pointer :reader pointer

+ :initarg :pointer

+ :documentation "Pointer to the C++ object.")

+ ;; We can not have a global table of objects owned by C++,

+ ;; since then they would be alway reacable from Lisp and thus

+ ;; cycles would never be garbage collected.

+ (owned-objects :accessor owned-objects

+ :initform nil

+ :type list

+ :documentation "Objecsts owned by the C++ instance."))

- (remove-wrapper-object object)

-(defun put-returnvalue (stack value type)

+(defun put-returnvalue (stack value type object)

- (disown-object value))))))

+ (transfer-ownership-to value object))))))

- (return-type method))

+ (return-type method)

+ object)

- (put-returnvalue stack return-value (return-type method))

+ (put-returnvalue stack return-value [_$_]

+ (return-type method)

+ (get-object object))

-(defvar *cxx-wrapper-objects* (make-synchronized-hash-table))

-

-(defun keep-wrapper (object)

- (assert (not (gethash object *cxx-wrapper-objects*)))

- (setf (gethash object *cxx-wrapper-objects*) object))

+(defun keep-wrapper (object new-owner)

+ (assert (not (member object (owned-objects new-owner)))

+ ()

+ "~A has already been called for ~A." #'keep-wrapper object)

+ (push object (owned-objects new-owner)))

-(defun remove-wrapper-object (object)

- (remhash object *cxx-wrapper-objects*))

+(defun remove-wrapper-object (object owner)

+ (remove object (owned-objects owner)))

-(defun disown-object (object)

+(defun transfer-ownership-to (object new-owner)

- (keep-wrapper object))

+ (keep-wrapper object new-owner))

-

-(defun take-ownership (object)

+(defun take-ownership (object &optional current-owner)

- (remove-wrapper-object object)

+ (when current-owner

+ (remove-wrapper-object object current-owner))

-

-;(eval-when (:load-toplevel)

-; (trace disown-object

-; keep-wrapper

-; remove-wrapper-object [_$_]

-;take-ownership

-;put-returnvalue

-;))

+(defun enum-logior (&rest enums)

+ (apply #'logior (mapcar #'value enums)))

+

+ #:enum-logior

- "Declares METHOD transfers the ownership of OBJECT to C++."

+ "Declares METHOD transfers the ownership of OBJECT to the

+first argument of LAMBDA-LIST."

- (disown-object ,object)))

+ (transfer-ownership-to ,object ,(if (consp (first lambda-list))

+ (first (first lambda-list))

+ (first lambda-list)))))

Wed Jun 3 23:55:26 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Added restarts to method dispatch callback.

- (let ((method (make-instance 'smoke-method

- :id method

- :smoke (smoke-get-smoke binding))))

- (let ((gf (get-gf-for-method method)))

- (if (null (gf-methods gf))

- (progn

- (when abstract

- (error "Abstract method ~S called." (name method)))

- nil)

- (let ((object (get-object object)))

- (if object

- (progn

- (put-returnvalue

- stack

- (apply gf object

- (stack-to-args

- (cffi:inc-pointer stack [_$_]

- (cffi:foreign-type-size

- 'smoke-stack-item))

- (get-first-argument method)))

- (return-type method))

- t)

- nil))))))

+ (let* ((method (make-instance 'smoke-method

+ :id method

+ :smoke (smoke-get-smoke binding))))

+ (loop

+ (restart-case

+ (return-from dispatch-method

+ (let ((gf (get-gf-for-method method)))

+ (if (null (gf-methods gf))

+ (progn

+ (when abstract

+ (error "Abstract method ~A called."

+ (method-declaration method)))

+ nil)

+ (let ((object (get-object object)))

+ (if object

+ (progn

+ (put-returnvalue

+ stack

+ (apply gf object

+ (stack-to-args

+ (cffi:inc-pointer stack [_$_]

+ (cffi:foreign-type-size

+ 'smoke-stack-item))

+ (get-first-argument method)))

+ (return-type method))

+ t)

+ nil)))))

+ (call-default ()

+ :report (lambda (stream)

+ (format stream "Call default implementation ~A instead."

+ method))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (not abstract))

+ (return-from dispatch-method nil))

+ (use-returnvalue (return-value)

+ :report (lambda (stream)

+ (format stream "Supply a return value for ~A."

+ (method-declaration method)))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (not (void-p (return-type method))))

+ :interactive (lambda ()

+ (format *query-io* "~&Enter a new return value: ")

+ (multiple-value-list (eval (read *query-io*))))

+ (put-returnvalue stack return-value (return-type method))

+ (return-from dispatch-method t))

+ (return ()

+ :report (lambda (stream)

+ (format stream "Return void for ~A."

+ (method-declaration method)))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (void-p (return-type method)))

+ (return-from dispatch-method (values)))

+ (retry ()

+ :report (lambda (stream)

+ (format stream "Try again calling ~A" [_$_]

+ (method-declaration method))))))))

-(defun report-finalize-error (condition function object pointer)

- (warn "error calling finalizer ~A for ~A ~A:~%~5T~A"

- function object pointer condition))

+(defun report-finalize-error (condition function class pointer)

+ "Report the error CONDITION it the finalizer FUNCTION for the

+object at POINTER of class CLASS."

+ (warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%"

+ function class pointer condition))

-

-/** Invoked whne a Smoke method gets called. */

+/** Invoked when a Smoke method gets called. */

- return dispatch(this, method, object, stack, abstract);

+ int ret = dispatch(this, method, object, stack, abstract);

+ Q_ASSERT( !abstract || ret );

+

+ return ret;

-#include <stdexcept>

- }

- catch (std::exception& e)

+ } [_$_]

+ // This catch is mostly useless:

+ // Qt / KDElibs do not use exceptions and since they are often built with -fno-exceptions

+ // the catch will have no effect and the terminate handler is called instead.

+ catch (const std::exception& e) [_$_]

- return;

-

Mon Jun 1 00:22:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* fix define-takes-ownership return value

- `(defmethod ,method ,lambda-list

- (cancel-finalization ,object)

- (remove-object ,object)))

+ `(defmethod ,method :before ,lambda-list

+ (disown-object ,object)))

Sun May 31 19:41:26 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Ownership for return values on the stack

-(defclass smoke-wrapper-class (smoke-standard-class)

+(defclass cxx:class (smoke-standard-class)

- :type symbol)))

+ :type symbol))

+ (:documentation "Metaclass to extend Smoke Objects."))

-(defmethod smoke ((class smoke-wrapper-class))

+(defmethod smoke ((class cxx:class))

-(defclass cxx:class (smoke-wrapper-class)

- ()

- (:documentation "Metaclass to extend Smoke Objects."))

-

-(defmethod closer-mop:validate-superclass ((class smoke-wrapper-class) (superclass smoke-standard-class))

+(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))

- ((class smoke-wrapper-class)

+ ((class cxx:class)

- ((class smoke-wrapper-class)

+ ((class cxx:class)

+ (remove-wrapper-object object)

+ "Returns ARGUMENT converted to TYPE. If USER is true, user defined

+conversion sequences are considered."

- (cancel-finalization converted-value) [_$_]

- (when (and (class-p type)

- (not (virtual-destructor-p (get-class type))))

- (if (pointerp converted-value)

- (remove-object converted-value)

- (progn

- (cancel-finalization value)

- (remove-object (pointer value))))))))))

+ (cancel-finalization converted-value)

+ (disown-object value))))))

+

+(defvar *cxx-wrapper-objects* (make-synchronized-hash-table))

+

+(defun keep-wrapper (object)

+ (assert (not (gethash object *cxx-wrapper-objects*)))

+ (setf (gethash object *cxx-wrapper-objects*) object))

+

+(defun remove-wrapper-object (object)

+ (remhash object *cxx-wrapper-objects*))

+

+(defun disown-object (object)

+ "Transfers the ownership of OBJECT to C++."

+ (cancel-finalization object)

+ (if (typep (class-of object) 'cxx:class)

+ (progn

+ (assert (virtual-destructor-p (class-of object))

+ ()

+ "The ownership of the object ~A is transfered to C++, but

+it has a nonvirtual destructor." object)

+ (keep-wrapper object))

+ (when (and (typep object 'smoke-standard-object)

+ (not (virtual-destructor-p (class-of object))))

+ (remove-object (pointer object)))))

+ [_$_]

+

+

+(defun take-ownership (object)

+ "Assigns the ownership of OBJECT to Lisp. i.e.:

+cl-smoke is responsible for deleting the object."

+ (remove-wrapper-object object)

+ (let ((finalizer (make-finalize object)))

+ (finalize object finalizer)))

+

+;(eval-when (:load-toplevel)

+; (trace disown-object

+; keep-wrapper

+; remove-wrapper-object [_$_]

+;take-ownership

+;put-returnvalue

+;))

-(defun make-weak-synchronized-hash-table (&key weakness)

- (make-weak-hash-table :weakness weakness :synchronized t))

+(defun make-synchronized-hash-table (&key weakness)

+ (if weakness

+ (make-weak-hash-table :weakness weakness :synchronized t)

+ (make-weak-hash-table :synchronized t)))

- (defun make-weak-synchronized-hash-table (&key weakness)

- (make-weak-hash-table :weakness weakness)))

+ (defun make-synchronized-hash-table (&key weakness)

+ (if weakness

+ (make-weak-hash-table :weakness weakness)

+ (make-weak-hash-table))))

-(cerror "Use unsynchronized hash-table"

- "Synchronized hash table not implemented.")

-(defun make-weak-synchronized-hash-table (&key weakness)

- #-cmucl (make-weak-hash-table :weakness weakness)

- #+cmucl (make-hash-table :weak-p weakness)

- ))

+ (cerror "Use unsynchronized hash-table"

+ "Synchronized hash table not implemented.")

+ (defun make-synchronized-hash-table (&key weakness)

+ (if weakness

+ #-cmucl (make-weak-hash-table :weakness weakness)

+ #+cmucl (make-hash-table :weak-p weakness)

+ (make-hash-table))))

-(defvar *object-map* (make-weak-synchronized-hash-table :weakness :value))

+(defvar *object-map* (make-synchronized-hash-table :weakness :value)

+ "Contains all objects constructed by Smoke, that are not yet destructed;

+except object with a non virtual destuctor which had their ownership transfered

+to C++.")

+(defun report-finalize-error (condition function object pointer)

+ (warn "error calling finalizer ~A for ~A ~A:~%~5T~A"

+ function object pointer condition))

- (condition (condition)

- (format *debug-io* "error finalize ~A ~A~%" (name class)

- condition))))))

- [_$_]

-

-(defun take-ownership (object)

- "Assigns the ownership of OBJECT to Lisp. i.e.:

-cl-smoke is responsible for deleting the object."

- (let ((finalizer (make-finalize object)))

- (finalize object finalizer)))

+ (error (condition)

+ (report-finalize-error condition 't (name class) pointer))))))

+ (assert (valid-p method)

+ ()

+ "No applicable method ~A() for ~A." name object-or-class)

-

Sat May 30 14:12:25 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* soversion for wrappers

+set_target_properties(smoke-c

+ PROPERTIES

+ SOVERSION "0.0"

+ VERSION "0.0.1")

+set_target_properties(smoke-c-util

+ PROPERTIES

+ SOVERSION "0.0"

+ VERSION "0.0.1")

Thu May 28 15:43:36 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix CCL and allow ASDF

- (declare (smoke-class smoke-class))

- :type (integer 0)

+ :type integer

- :type foreign-pointer

+ #:define-takes-ownership

+ #-mudballs

+ (define-foreign-library libsmoke-c

+ (:unix "libsmoke-c.so")

+ (t (:default "libsmoke-c")))

+ #-mudballs

+ (define-foreign-library libsmoke-c-util

+ (:unix "libsmoke-c-util.so")

+ (t (:default "libsmoke-c-util")))

+(defmacro define-takes-ownership (method lambda-list object)

+ "Declares METHOD transfers the ownership of OBJECT to C++."

+ `(defmethod ,method ,lambda-list

+ (cancel-finalization ,object)

+ (remove-object ,object)))

+

+

Wed May 27 19:47:28 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Condition NO-APPLICABLE-CXX-METHOD

+ ;; FIXME warn but not on void**

+

+(defun format-no-applicable-cxx-method (stream name class arguments)

+ (format stream

+ "No applicable method ~S of ~A for ~S.

+Candidtes are:~{~T~%~}."

+ name class arguments

+ (mapcar #'signature

+ (viable-functions name

+ (length arguments)

+ (smoke-class-of class)))))

+

+(define-condition no-applicable-cxx-method (error)

+ ((method :initarg :method :reader condition-method)

+ (class :initarg :class :reader condition-class)

+ (arguments :initarg :arguments :reader condition-arguments))

+ (:report (lambda (condition stream)

+ (format-no-applicable-cxx-method stream

+ (condition-method condition)

+ (condition-class condition)

+ (condition-arguments condition)))))

- (error "No applicable method ~S of ~A for ~S.

-Candidates are:~{~T~A~%~}."

- name object-or-class arguments

- (mapcar #'signature

- (viable-functions name

- (length arguments)

- (smoke-class-of object-or-class)))))

+ (error (make-condition 'no-applicable-cxx-method

+ :method name

+ :class object-or-class

+ :arguments arguments)))

Wed May 27 19:22:08 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix error when printing a SMOKE-OBJECT with an unbound pointer slot.

- (print-unreadable-object (object stream :type t)

- (princ (pointer object) stream)))

+ (if (slot-boundp object 'pointer)

+ (print-unreadable-object (object stream :type t)

+ (princ (pointer object) stream))

+ (call-next-method)))

Wed May 27 14:20:30 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix some warnings

- (:components "object" "enum" "method" "class"

- "type" "instance" "stack"))

+ (:components "object" "enum" "type" "method" "class"

+ "instance" "stack"))

- (declare (smoke-class smoke-class)

- (smoke-standard-class class))

+ (declare (smoke-class smoke-class))

-(defgeneric get-flag (object flag)

- (:documentation "Returns the value for FLAG of OBJECT."))

-

+(defgeneric size (object))

+(defgeneric get-flag (object flag)

+ (:documentation "Returns the value for FLAG of OBJECT."))

+

-(defmethod const-p ((type smoke-type))

- "Returns T when TYPE is const; NIL otherwise."

- (/= 0 (get-flag type :const)))

+(defgeneric const-p (object)

+ (:method ((type smoke-type))

+ "Returns T when TYPE is const; NIL otherwise."

+ (/= 0 (get-flag type :const))))

- (multiple-value-bind (method sequence)

- (call-using-types find-best-viable-function2

- (if (using-typep)

- #'standard-conversion-sequence-using-types

- #'standard-conversion-sequence)

- (format nil "~A" (name (get-class type)))

- (list object) to-class)

- (when method

+ (when (call-using-types find-best-viable-function2

+ (if (using-typep)

+ #'standard-conversion-sequence-using-types

+ #'standard-conversion-sequence)

+ (format nil "~A" (name (get-class type)))

+ (list object) to-class)

- 'coerce-to-class

- to-class))))))

+ 'coerce-to-class

+ to-class)))))

- (let ((method-name (concatenate 'string "~" (name object))))

+ (let ((method-name (concatenate 'string "~" (name (class-of object)))))

- (make-smoke-method object method-name)

+ (make-smoke-method (class-of object) method-name)

+ (declare (ignore smoke-class))

Tue May 26 11:54:47 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cleanup Lisp -> C++ conversion

-(declaim (optimize (speed 0) (debug 3)))

-

-(defgeneric set-returnvalue (stack value type))

-(defmethod set-returnvalue (stack (value smoke-standard-object) type)

- (assert (class-p type)

- (type)

- "The type ~A of the value ~A is not a class."

- (name type) value)

- (setf (foreign-slot-value stack 'smoke-stack-item 'class)

- (cast value (find-smoke-class (get-class type))))

- ;(pointer value))

- (when (stack-p type) ;; Pass by value => smoke deletes the object.

- (cancel-finalization value) [_$_]

- (unless (virtual-destructor-p (class-of value))

- (remove-object (pointer value))))) ;; Fixme mark object as invalid or copy it

-

-

-(defmethod set-returnvalue (stack (value integer) type)

- (setf (foreign-slot-value stack 'smoke-stack-item 'int)

- value))

-

-(defmethod set-returnvalue (stack (value (eql t)) type)

- (setf (foreign-slot-value stack 'smoke-stack-item 'bool)

- value))

+(defun convert-argument (argument type &optional (user t))

+ (let ((rank (get-conversion-sequence argument type user)))

+ (if (null rank)

+ (error "Can not convert the argument ~S to ~A."

+ argument (name type))

+ (funcall (conversion-function-name rank)

+ argument))))

- (set-returnvalue stack value type)))

+ (let ((stack (make-call-stack stack)))

+ (setf (top stack) (pointer stack))

+ ;; FIXME support user conversions.

+ ;; We need to determine which of value and converted-value is

+ ;; passed on the stack. E.g. converted-value can be something like

+ ;; (cxx:operator-variant value).

+ (let ((converted-value (convert-argument value type nil)))

+ (push-smoke-stack stack converted-value (type-id type))

+ (when (stack-p type) ;; Pass by value => smoke deletes the object.

+ (cancel-finalization converted-value) [_$_]

+ (when (and (class-p type)

+ (not (virtual-destructor-p (get-class type))))

+ (if (pointerp converted-value)

+ (remove-object converted-value)

+ (progn

+ (cancel-finalization value)

+ (remove-object (pointer value))))))))))

- ((binding :pointer)

- (method smoke-index)

- (object :pointer)

- (stack smoke-stack)

- (abstract :boolean))

+ ((binding :pointer)

+ (method smoke-index)

+ (object :pointer)

+ (stack smoke-stack)

+ (abstract :boolean))

- (put-returnvalue stack

- (apply gf object

- (stack-to-args (cffi:inc-pointer stack (cffi:foreign-type-size 'smoke-stack-item))

- (get-first-argument method)))

- (return-type method))

+ (put-returnvalue

+ stack

+ (apply gf object

+ (stack-to-args

+ (cffi:inc-pointer stack [_$_]

+ (cffi:foreign-type-size

+ 'smoke-stack-item))

+ (get-first-argument method)))

+ (return-type method))

-(defmethod get-struct-slot-value ((class smoke-class) slot-name)

+(declaim (inline class-slot-value))

+(defun class-slot-value (class slot-name)

- (get-struct-slot-value class 'name))

+ (class-slot-value class 'name))

- (get-struct-slot-value class 'external))

+ (class-slot-value class 'external))

- (boole boole-and (get-struct-slot-value class 'flags)

+ (boole boole-and (class-slot-value class 'flags)

- (smoke-add-superclass class nil (get-struct-slot-value class 'parents)))

+ (smoke-add-superclass class nil (class-slot-value class 'parents)))

+ :type (integer 0)

-(declaim (optimize (debug 3)))

+(declaim (inline method-slot-value))

+ :type smoke-index

+ :type foreign-pointer

-(declaim (optimize (debug 3)))

+ :type foreign-pointer

- :documentation "Pointer to push the next argument to.")

- (cleanup-stack :accessor cleanup-stack

- :initform nil

- :documentation "Cleanup functions"))

+ :type foreign-pointer

+ :documentation "Pointer to push the next argument to."))

-(defun push-cleanup (stack function)

- "Adds the cleanup function FUNCTION to STACK"

- (push function (cleanup-stack stack)))

-

-(defun push-stack2 (stack value type-id)

+(defun push-smoke-stack (stack value type-id)

- (13 (push-stack stack value 'class))))

-

-(defun push-smoke-stack (stack lisp-value smoke-type)

- (typecase smoke-type

- (smoke-type

- (cond

- ((cffi:pointerp lisp-value)

- (push-stack2 stack lisp-value (type-id smoke-type)))

- ((class-p smoke-type)

- (push-stack2 stack

- (convert-to-class (get-class smoke-type) lisp-value)

- (type-id smoke-type)))

-; ((pointer-p smoke-type)

- (t

- (let ((cffi-type (get-type (name smoke-type))))

- (if (null cffi-type)

- (progn

- ; (assert (typep lisp-value 'foreign-pointer)

- ; (lisp-value)

- ; "The lisp-value ~S is not a foreign-pointer."

- ; lisp-value)

- (push-stack2 stack

- lisp-value

- (type-id smoke-type)))

- (multiple-value-bind (pointer args) (convert-to-foreign lisp-value

- cffi-type)

- (push-cleanup stack

- #'(lambda ()

- (free-converted-object pointer

- cffi-type

- args)))

- (push-stack2 stack

- pointer

- (type-id smoke-type))))))))

-; (t (push-stack2 stack lisp-value (type-id smoke-type)))))

- (t (push-lisp-object stack lisp-value smoke-type))))

-

-(defgeneric push-lisp-object (stack object class)

- (:documentation "Push the OBJECT on STACK."))

+ (13 (if (typep value 'smoke-standard-object)

+ ;; FIXME call pointer in overload resolution

+ (push-stack stack (pointer value) 'class)

+ (push-stack stack value 'class)))))

- (push-smoke-stack stack (first args) (first arguments))

- (set-smoke-stack stack (rest args) (rest arguments))))

+ (if (typep (first arguments) 'smoke-type)

+ (push-smoke-stack stack (first args) (type-id (first arguments)))

+ (push-stack stack (first args) 'class)) ;; Used for :qt lisp-object

+ (set-smoke-stack stack (rest args) (rest arguments))))

- (unwind-protect

- (progn

- ,@body)

- (mapcar #'funcall (cleanup-stack ,stack)))))))

+ ,@body))))

-

- [_$_]

+(declaim (inline type-slot-value))

- (null (name type)))

+ ;; void is an empty string.

+ ;; For efficency just check if the first byte is a null byte;

+ ;; No need to convert the entire C string to lisp like in:

+ ;; (null (name type)))

+ (= 0 (mem-ref (smoke-get-type (smoke type) (id type))

+ :char)))

+ [_$_]

-(declaim (optimize (debug 3)))

+ :type fixnum

+ :type fixnum

+ :type fixnum

+ :type fixnum

+ :type fixnum

+ :type fixnum

- (13 (and (object.typep (find-class 'smoke-standard-object))

- (smoke-type= type (object.type-of))))))

+ (13 (and (object.typep 'smoke-standard-object)

+ (smoke-type= (get-class type) (object.type-of))))))

- "Returns a pointer that calls CLEANUP-FUNCTION when it is finalized."

+ "Returns a pointer that calls CLEANUP-FUNCTION with pointer as argument

+when it is finalized."

- (let ((address (pointer-address pointer)))

- (tg:finalize pointer #'(lambda ()

- (foreign-free (make-pointer address))))))

+ (make-cleanup-pointer pointer #'foreign-free))

+(declaim (inline coerce-to-class))

+(declaim (inline coerce-to-class))

+ (declare (optimize (speed 3)))

Mon May 25 20:39:33 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* speed up get-struct-slot-value & cleanup

-(defun make-smoke-constructor (class args)

- (find-method-using-args class

- (name class)

- args))

-

-(in-package :smoke)

-

-(declaim (optimize (debug 3)))

-

-(defmacro average (&rest args)

- `(floor (+ ,@args) ,(length args)))

- [_$_]

-

-(defun binary-find (lower upper < =)

- (let ((mid (average lower upper)))

- (if (= mid lower)

- nil

- (if (funcall = mid)

- mid

- (if (funcall < mid)

- (binary-find lower mid < =)

- (binary-find mid upper < =))))))

-

-(defun serach-method (smoke name)

- (binary-find 1 (smoke-method-name-size smoke)

- #'(lambda (index)

- (string< name

- (smoke-get-method-name smoke index)))

- #'(lambda (index)

- (string= name

- (smoke-get-method-name smoke index)))))

-

-(defun find-last (lower upper =)

- (if (or (>= lower upper)

- (not (funcall = (1+ lower))))

- lower

- (find-last (1+ lower) upper =)))

- [_$_]

- [_$_]

-(defun find-methods (smoke name)

- (let* ((index (serach-method smoke name))

- (= #'(lambda (index)

- (string= name

- (smoke-get-method-name smoke index)

- :end2 (length name))))

- (upper (find-last index (smoke-method-name-size smoke) =))

- (methods nil))

- (loop for i from index to upper do

- (push (smoke-get-method-name smoke i)

- methods))

- methods))

- [_$_]

- [_$_]

-

-;(defmethod exact-match ((object singl-float) type))

-(defun type-equal (type type-name)

- (equal (name type) type-name))

-

-(defun exact-match (object type)

- (format t "~A ~A~%" object (name type))

- (ctypecase object [_$_]

- (smoke-standard-object

- (and (class-p type)

- (derived-p (class-of object)

- (get-class type))))

- (double-float (type-equal type "double"))

- (single-float (type-equal type "float"))

- (integer (type-equal type "int"))

- (string (or (type-equal type "const char*")

- (type-equal type "const QString&")))

- (character (type-equal type "char"))))

-

-(defun exact-match-p (arguments types)

- (if (or (null arguments) (null types))

- (and (null arguments)

- (null types))

- (if (not (exact-match (first arguments)

- (first types)))

- nil

- (exact-match-p (rest arguments)

- (rest types)))))

- [_$_]

-(defun promotion-match (object type)

- (ctypecase object

- (character (type-equal type "int"))

- (float (type-equal type "double"))

- (boolean (type-equal type "int"))))

-

-(defun standard-conversion-match (object type)

- (ctypecase object

- (number (or (type-equal type "short")

- (type-equal type "int")

- (type-equal type "long")))))

-

-(defun constructor-match (object type)

- (if (class-p type)

- (let ((constructor (make-smoke-constructor (get-class type)

- (mung-arg object))))

- (exact-match object (get-first-argument constructor)))

- nil))

- [_$_]

-(defun find-ambiguous-method (predicate method)

- (let ((index (- (id method))))

- (loop as i = (smoke-ambiguous-method (smoke method)

- index)

- while (> i 0) do

- (incf index)

- (let ((ambiguous-method (make-instance 'smoke-method

- :smoke (smoke method)

- :id i)))

- (when (funcall predicate ambiguous-method)

- (return ambiguous-method))))))

-

-(defun find-method-using-args (class name arguments)

- (with-foreign-object (m 'smoke-module-index)

- (smoke-find-method m (smoke class) (id class)

- (concatenate 'string name

- (munged-args arguments)))

- (let ((method (make-instance 'smoke-method

- :smoke (foreign-slot-value m

- 'smoke-module-index

- 'smoke)

- :id (foreign-slot-value m

- 'smoke-module-index

- 'index))))

- (when (< (id method) 0)

- (setf method

- (find-ambiguous-method #'(lambda (method)

- (exact-match-p arguments (arguments method)))

- method))

- (assert (not (null method)) (method)

- "No method ~A::~A for the arguments ~A"

- (name class) name arguments))

- method)))

-

-

-(defgeneric get-convert-function (to from))

-(defmethod get-convert-function ((to eql 'int) (from eql 'char)))

-(defmethod get-convert-function ((to cxx::int) (from string)))

-

-(get-convert-function 'int 'char)

-

-;'const int 'char:

-(get-convert-function 'int 'char)

-&& (convert-const-p 'char)

-

-;'int 'const char:

-(get-convert-function 'int 'char)

-&& (not (const-p 'char))

-

-

-(defclass int ()

- ((const-p)))

-

-(defun get-convert-function (to from))

-

- [_$_]

-(defun type-equal (type type-name)

- "Returns true when TYPE is of the type named TYPE-NAME and false otherwise."

- (equal (name type) type-name))

-

-(defun exact-match (object type)

- "Returns true when the type of OBJECT is exactly the same as TYPE and

-false otherwise."

- (ctypecase object [_$_]

- (smoke-standard-object

- (and (class-p type)

- (derived-p (class-of object)

- (get-class type))))

- (double-float (type-equal type "double"))

- (single-float (type-equal type "float"))

- (integer (type-equal type "int"))

- ;; int is also enum

- ;; FIXME remove magic number 12

- ;;(= (type-id type) 12)))

- (string (or (type-equal type "const char*")

- (type-equal type "const QString&")))

- (enum (smoke-type= (enum-type object)

- type))

- (sequence (type-equal type "const QStringList&"))

- (character (type-equal type "char"))))

-

-(defun exact-match-p (arguments types)

- "Returns true when all the type of ARGUMENTS is the same as the

-corresponing type of TYPES and the length of the ARGUMENTS and TYPES list

-is equal."

- (if (or (null arguments) (null types))

- (and (null arguments)

- (null types))

- (if (not (exact-match (first arguments)

- (first types)))

- nil

- (exact-match-p (rest arguments)

- (rest types)))))

-

-(defun mung-arg (argument)

- "Returns the mung char for ARUGMENT."

- ;; FIXME void* is #\$ but void[] is #\?

- ;; FIXME Get rid of the mugging stuff and compute the applicable methods

- ;; including argument promotion

- (case argument

- ((t nil) #\$) ;; Booleans

- (otherwise

- (ctypecase argument

- (number #\$)

- (character #\$)

- (string #\$)

- (foreign-pointer #\?)

- (sequence #\?)

- (enum #\$)

- (smoke-standard-object #\#)))))

-

-(defun munged-args (arguments &optional (string nil))

- "Maps the type of every item of ARGUMENTS to a char;

-Returns the list of the chars."

- (if (null arguments)

- string

- (munged-args (rest arguments)

- (append string (list (mung-arg (first arguments)))))))

-

-(defun find-ambiguous-method (predicate method)

- "Returns a method of the ambiguous method METHOD such that

-PREDICATE is true. NIL is returned when no matching method is found."

- (assert (ambiguous-p method)

- (method)

- "The method is not ambiguous.")

- (let ((index (- (id method))))

- (loop as i = (smoke-ambiguous-method (smoke method)

- index)

- while (> i 0) do

- (incf index)

- (let ((ambiguous-method (make-instance 'smoke-method

- :smoke (smoke method)

- :id i)))

- (when (funcall predicate ambiguous-method)

- (return ambiguous-method))))))

-

-(defun find-method-using-args (class name arguments)

- "Returns the method of class CLASS with the name NAME

-for the arguments ARGUMENTS."

- (with-foreign-object (m 'smoke-module-index)

- (smoke-find-method m (smoke class) (id class)

- (concatenate 'string name

- (munged-args arguments)))

- (let ((method (make-instance 'smoke-method

- :smoke (foreign-slot-value m

- 'smoke-module-index

- 'smoke)

- :id (foreign-slot-value m

- 'smoke-module-index

- 'index))))

- (assert (valid-p method)

- (method)

- "No method ~A::~A for the arguments ~A" (name class) name arguments)

- (when (ambiguous-p method)

- (setf method

- (find-ambiguous-method #'(lambda (method)

- (exact-match-p arguments (arguments method)))

- method))

- (assert (not (null method)) (method)

- "No method ~A::~A for the arguments ~A"

- (name class) name arguments))

- method)))

-

-

-(defmethod get-struct-slot-value ((method smoke-method) slot-name)

+(defun method-slot-value (method slot-name)

+ (declare (smoke-method method)

+ (symbol slot-name)

+ (optimize (speed 3)))

- (get-struct-slot-value method 'name)))

+ (method-slot-value method 'name)))

- :id (get-struct-slot-value method 'return-type)

+ :id (method-slot-value method 'return-type)

- (logand (get-struct-slot-value method 'flags)

+ (logand (method-slot-value method 'flags)

- :id (get-struct-slot-value method 'class)

+ :id (method-slot-value method 'class)

- (get-struct-slot-value method 'num-args))

+ (method-slot-value method 'num-args))

- :id (get-struct-slot-value method 'arguments)

+ :id (method-slot-value method 'arguments)

- :id (+ (get-struct-slot-value method 'arguments) index)

+ :id (+ (method-slot-value method 'arguments) index)

-(defmethod get-struct-slot-value ((type smoke-type) slot-name)

+(defun type-slot-value (type slot-name)

+ (declare (smoke-type type)

+ (symbol slot-name)

+ (optimize (speed 3)))

- (get-struct-slot-value type 'name))

+ (type-slot-value type 'name))

- (logand (get-struct-slot-value type 'flags)

+ (logand (type-slot-value type 'flags)

- (logand (get-struct-slot-value type 'flags)

+ (logand (type-slot-value type 'flags)

- (/= -1 (get-struct-slot-value type 'class))))

+ (/= -1 (type-slot-value type 'class))))

- (logand (get-struct-slot-value type 'flags)

+ (logand (type-slot-value type 'flags)

- (assert (/= -1 (get-struct-slot-value type 'class))

+ (assert (/= -1 (type-slot-value type 'class))

- :id (get-struct-slot-value type 'class)

+ :id (type-slot-value type 'class)

Sun May 24 23:28:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Allow passing a raw pointer for an argument of type class

- (when (and (= 0 (type-id type))

+ ;; Not using pointer-p to allow passing a raw pointer for

+ ;; objects on the stack and references

+ ;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )

+ ;;

+ ;; FIXME this breaks passing pointers to references

+ ;; e.g.: calling the function foo(QByteArray& foo)

+ ;; with (foo pointer) assumes pointer to point to a QByteArray,

+ ;; but actually the conversion sequence QByteArray(pointer) should be used.

+ ;; When pointer is a null pointer it fails horribly!.

+ (when (and (or (= 0 (type-id type)) ; voidp

+ (= 13 (type-id type))) ; class

- :from (object.type-of)

- :to (find-class 't))))

+ :from (find-class 't)

+ :to (find-class 't)))) ;; FIXME get the class when applicable

Sun May 24 13:30:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* cleanup finalization stuff

- :documentation "Pointer to the C++ object.")

- (owned-p :accessor owned-p :initarg :owned-p

- :initform t

- :documentation "T when the object is owned by Lisp and

-NIL when C++ is the owner.")

- (const-p :reader const-p :initarg :const-p

- :initform nil

- :documentation "T when the object is const and NIL otherwise."))

+ :documentation "Pointer to the C++ object."))

- ((enumerations :initform (make-hash-table)

- :initarg :enumerations

- :reader enumerations

- :documentation "The enumerations of the class.

-Maps the type-id of the enumeration to a hash-table that

-maps an enum value to a symbol."))

+ ()

-(defun smoke-class-symbol (class)

- (if (external-p class)

- (class-name (find-smoke-class class))

- (lispify (name class))))

+(defun smoke-class-symbol (smoke-class)

+ "Returns the Lisp class-name of SMOKE-CLASS:"

+ (if (external-p smoke-class)

+ (class-name (find-smoke-class smoke-class))

+ (lispify (name smoke-class))))

- (pointer value))

+ (cast value (find-smoke-class (get-class type))))

+ ;(pointer value))

- (cancel-finalization value) ;; Fixme mark object as invalid or copy it

- ;(remove-object (pointer value))

- (remove-if-exists (pointer value));;FIXME!

- (setf (slot-value value 'pointer) (null-pointer))))

+ (cancel-finalization value) [_$_]

+ (unless (virtual-destructor-p (class-of value))

+ (remove-object (pointer value))))) ;; Fixme mark object as invalid or copy it

+

-;(eval-startup (:execute)

-; (memoize:memoize-function 'get-gf-for-method)

-; (memoize:clear-memoized-function 'get-gf-for-method))

-

- (setf (slot-value object 'owned-p) t)

+ (take-ownership object)

- :owned-p (stack-p type)

+ (when (stack-p type)

+ (take-ownership ret)

+ (add-object ret))

+(defun take-ownership (object)

+ "Assigns the ownership of OBJECT to Lisp. i.e.:

+cl-smoke is responsible for deleting the object."

+ (let ((finalizer (make-finalize object)))

+ (finalize object finalizer)))

+ [_$_]

+ "Adds OBJECT to the pointer -> object map. It can later be retrived

+with GET-OBJECT."

- (when (owned-p object)

- (let ((finalizer (make-finalize object)))

- (finalize object finalizer)))

+(defun virtual-destructor-p (class)

+ "Returns T when CLASS has a virtual destructor and NIL otherwise."

+ (/= 0 (get-flag class :virtual-destructor)))

+

- (object-to-lisp (foreign-slot-value stack-item

- 'smoke-stack-item

- 'class)

- type))

+ (let ((object (object-to-lisp (foreign-slot-value stack-item

+ 'smoke-stack-item

+ 'class)

+ type)))

+ object))

- (boole boole-and (get-struct-slot-value type 'flags)

- (foreign-enum-value 'smoke-type-flags flag)))

+ (logand (get-struct-slot-value type 'flags)

+ #xF0 ;; = ! 0x0F

+ (foreign-enum-value 'smoke-type-flags flag)))

+

+(defun get-allocation-flag (type)

+ (logand (get-struct-slot-value type 'flags)

+ #x30))

- (/= 0 (get-flag type :stack)))

+ (= (get-allocation-flag type) (get-flag type :stack)))

- (/= 0 (get-flag type :reference)))

+ (= (get-allocation-flag type) (get-flag type :reference)))

- (/= 0 (get-flag type :pointer)))

+ (= (get-allocation-flag type) (get-flag type :pointer)))

- (boole boole-and (get-struct-slot-value type 'flags)

- (foreign-enum-value 'smoke-type-flags :type-id)))

+ (logand (get-struct-slot-value type 'flags)

+ (foreign-enum-value 'smoke-type-flags :type-id)))

+

Fri May 22 16:57:59 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Use synchronized object-map

-(defvar *object-map* [_$_]

- #-cmucl (make-weak-hash-table :weakness :value)

- #+cmucl (make-hash-table :weak-p :value)

- [_$_]

- "Maps a lisp object to Smoke C++ object.")

+#+sbcl [_$_]

+(defun make-weak-synchronized-hash-table (&key weakness)

+ (make-weak-hash-table :weakness weakness :synchronized t))

-;; FIXME This probably does not scale well. A per thread object-map

-;; or at least a read-write lock should be used.

-;; => use :synchronized of sbcl hash-table

-(defvar *object-map-mutex* (make-lock "object-map lock"))

+#+openmcl

+(let ((ccl::*shared-hash-table-default* t))

+ (defun make-weak-synchronized-hash-table (&key weakness)

+ (make-weak-hash-table :weakness weakness)))

+

+#-(or sbcl openmcl)

+(progn

+(cerror "Use unsynchronized hash-table"

+ "Synchronized hash table not implemented.")

+(defun make-weak-synchronized-hash-table (&key weakness)

+ #-cmucl (make-weak-hash-table :weakness weakness)

+ #+cmucl (make-hash-table :weak-p weakness)

+ ))

+ [_$_]

+

+(defvar *object-map* (make-weak-synchronized-hash-table :weakness :value))

+

+(declaim (inline get-object))

- (with-lock-held (*object-map-mutex*)

- (gethash (pointer-address pointer) *object-map*)))

+ (gethash (pointer-address pointer) *object-map*))

+(declaim (inline (setf get-object)))

- (with-lock-held (*object-map-mutex*)

- (setf (gethash (pointer-address pointer) *object-map*)

- value)))

- [_$_]

+ (setf (gethash (pointer-address pointer) *object-map*)

+ value))

- (with-lock-held (*object-map-mutex*)

- (nth-value 1 (gethash (pointer-address pointer) *object-map*))))

+ (nth-value 1 (gethash (pointer-address pointer) *object-map*)))

+

+(defun remove-if-exists (pointer)

+ (remhash (pointer-address pointer) *object-map*))

+

+(defun remove-object (pointer)

+ (assert (has-pointer-p pointer)

+ (pointer)

+ "No object to remove for pointer ~A." pointer)

+ (remhash (pointer-address pointer) *object-map*))

-

-(defun remove-if-exists (pointer)

- (with-lock-held (*object-map-mutex*)

- (remhash (pointer-address pointer) *object-map*)))

-

-(defun remove-object (pointer)

- (assert (has-pointer-p pointer)

- (pointer)

- "No object to remove for pointer ~A." pointer)

- (with-lock-held (*object-map-mutex*)

- (remhash (pointer-address pointer) *object-map*)))

-

-(defun print-garbage ()

- (with-lock-held (*object-map-mutex*)

- (maphash #'(lambda (pointer object)

- (format t "~A of type: ~S~%"

- (make-pointer pointer)

- (class-name (class-of object))))

- *object-map*)))

Tue May 19 15:59:22 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Clozure CL save image

- (:components "get-value"

- ("image" (:for (:not :sbcl)))

- ("image-sbcl" (:for :sbcl)))))))

+ (:components

+ "get-value"

+ ("sbcl-bundle" (:for :sbcl))

+ (:image module

+ (:components [_$_]

+ ("image" (:needs "impl"))

+ (:impl module

+ (:components

+ ("sbcl" (:for :sbcl))

+ ("ccl" (:for :openmcl))

+ ("not-implemented" (:for (:not

+ (:or :sbcl :openmcl)))))))))))))

+ (:supports (:os :linux) (:implementation :sbcl :openmcl))

- :alexandria

- :trivial-garbage :bordeaux-threads))

+ :alexandria :trivial-garbage :bordeaux-threads))

-;(memoize:memoize-function 'get-gf-for-method)

+

+;(eval-startup (:execute)

+; (memoize:memoize-function 'get-gf-for-method)

+; (memoize:clear-memoized-function 'get-gf-for-method))

-(in-package :smoke)

-

-(eval-when (:compile-toplevel :load-toplevel :execute)

- (defvar *startup-functions* nil

- "Functions to run (in order) on startup.")

-

- (defun add-startup-function (function)

- (setf *startup-functions*

- (nconc *startup-functions* (list function))))

-

- (defun add-and-run-startup-function (function)

- (add-startup-function function)

- (funcall function))

-

- (defun run-startup-functions ()

- (mapcar #'funcall *startup-functions*)))

-

-(eval-when (:load-toplevel :execute)

- (push #'run-startup-functions sb-ext:*init-hooks*))

-

-(defmacro eval-startup ((&rest situations) &body body)

- "Runs BODY when it is loaded."

- `(eval-when (,@situations :load-toplevel)

- (add-and-run-startup-function #'(lambda ()

- (let ((*package* ,*package*))

- ,@body)))))

-

-(defun strip-foreign-libraries-path ()

- (dolist (library sb-alien::*shared-objects*)

- (setf (slot-value library 'namestring)

- (file-namestring (slot-value library 'pathname)))))

-

-(defun make-temporary-directory ()

- (pathname (concatenate 'string (sb-posix:mkdtemp "/tmp/cl-smokeXXXXXX")

- "/")))

-

-(defmacro with-temporary-directory ((directory) &body body)

- "Binds DIRECTORY to the pathname of a temporary directory and executes body:"

- `(let ((,directory (make-temporary-directory)))

- (unwind-protect (progn ,@body)

- (unless (zerop

- (sb-ext:process-exit-code

- (sb-ext:run-program "/bin/rm"

- (list "-r" (namestring ,directory)))))

- (cerror "ignore"

- "could not remove temponary directory ~A"

- ,directory)))))

- [_$_]

-(defun save-image (file-name &rest options &key &allow-other-keys)

- "Save the lisp image in FILE-NAME."

- (let ((pid (sb-posix:fork)))

- (if (= 0 pid)

- (progn