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

* Use libsmokebase instead of libsmokeqtcore.

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.

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.

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.

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

* Improve missing to-lisp-translator error message.

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

* Allow passing integers as enum arguments.

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

* Fix overload resolution exact match for long and ulong.

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

* Faster no overload resolution method lookup.

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

* Cache overload resolution on sbcl

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

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

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

* No need to construct a SmokeBinding per Smoke module.

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

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

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

* Fix casting across Smoke modules.

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

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.

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

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

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.

--- old-smoke/src/bindings.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/bindings.lisp 2014-10-20 04:28:14.000000000 +0200

@@ -5,10 +5,8 @@

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

--- old-smoke/src/clos.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-10-20 04:28:14.000000000 +0200

@@ -337,8 +337,7 @@

;; Receive virtual function calls.

(defcallback dispatch-method :boolean

- ((binding :pointer)

- (method smoke-index)

+ ((method smoke-index)

(object-ptr :pointer)

(stack smoke-stack)

(abstract :boolean))

@@ -347,13 +346,9 @@

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

+ (unless (null object)

(let* ((method (make-smoke-method

- :smoke (gethash (pointer-address

- (smoke-get-smoke binding))

- *smoke-modules*)

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

:id method)))

(loop

(restart-case

@@ -431,7 +426,9 @@

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

+ (id (class-of object))

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

+ (name-pointer class))))

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

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

(call-next-method)

@@ -455,16 +452,20 @@

;; The constructor name is the name of the class minus any namespace parts.

(defun constructor-name (class)

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

(if name-start

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

- (name class))))

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

+ name)))

(defun call-constructor (class arguments)

(multiple-value-bind (method sequence)

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

(when (null method)

(error "No constructor for class ~A with

the arguments ~S." class arguments))

--- old-smoke/src/libsmoke/CMakeLists.txt 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/libsmoke/CMakeLists.txt 2014-10-20 04:28:14.000000000 +0200

@@ -8,18 +8,32 @@

set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fvisibility=hidden -fvisibility-inlines-hidden")

endif(CXX_VISIBILITY)

+

+# FIXME look for smoke.h

+find_library(smokebase_LIB smokebase)

+if (smokebase_LIB)

+ set(smokebase_FOUND TRUE)

+endif (smokebase_LIB)

+

+if (smokebase_FOUND)

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

+else (smokebase_FOUND)

+ message(FATAL_ERROR "Could not find smokebase")

+endif (smokebase_FOUND)

+

+

set(SMOKE_C_SOURCES smoke.cpp smokebinding.cpp)

-add_library(clsmoke MODULE ${SMOKE_C_SOURCES})

+add_library(clsmoke SHARED ${SMOKE_C_SOURCES})

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

set_target_properties(clsmoke

PROPERTIES

SOVERSION "0.0"

VERSION "0.0.1")

-add_library(clsmokeutil MODULE smoke_util.cpp)

+add_library(clsmokeutil SHARED smoke_util.cpp)

set_target_properties(clsmokeutil

PROPERTIES

SOVERSION "0.0"

VERSION "0.0.1")

-install(TARGETS clsmoke clsmokeutil

- LIBRARY DESTINATION lib)

+install(TARGETS clsmoke clsmokeutil DESTINATION lib)

--- old-smoke/src/libsmoke/cl_smoke.h 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/libsmoke/cl_smoke.h 2014-10-20 04:28:14.000000000 +0200

@@ -34,18 +34,6 @@

/** A Binding */

typedef void* smoke_binding;

-/** 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);

-}

-

/** Casts the void pointer smoke to the Smoke class.

* @param smoke the Smoke module

*

--- old-smoke/src/libsmoke/class.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/libsmoke/class.lisp 2014-10-20 04:28:14.000000000 +0200

@@ -5,6 +5,7 @@

(:constructor #x01)

(:copy-constructor #x02)

(:virtual-destructor #x04)

+ (:namespace #x08)

(:undefined #x10))

(defcstruct smoke-class

@@ -21,6 +22,7 @@

(m :pointer smoke-module-index)

(name :string))

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

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

(smoke :pointer)

(name :string))

--- old-smoke/src/libsmoke/smoke.cpp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/libsmoke/smoke.cpp 2014-10-20 04:28:14.000000000 +0200

@@ -12,21 +12,12 @@

extern "C" {

-/** 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 get_smoke_binding(binding)->get_smoke();

-}

-

/** Creates a new Smoke binding.

* The binding is allocated on the heap an can be freed with smoke_destruct().

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

* @related cl_smoke::Binding

+ * @related cl_smoke::NoDispatchBinding

+ * @related cl_smoke_destruct_binding

* @param smoke pointer to a Smoke module instance

* @param destruct callback for object destruction

* @param dispatch method dispatch callback

@@ -34,24 +25,26 @@

* @return a pointer to a new Smoke binding.

*/

CL_SMOKE_EXPORT smoke_binding

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

+cl_smoke_construct_binding(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(reinterpret_cast<NoDispatchBinding::destructed>(destruct));

+ else

+ return new Binding(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_EXPORT void

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

* @param smoke the Smoke module

*

* @return the module name

@@ -191,7 +184,7 @@

/** Finds a method of a class.

* @param m pointer to write the result to

- * @param smoke the smoke binding

+ * @param smoke the smoke module

* @param class_index index of the class

* @param method_name method name

*/

@@ -199,8 +192,14 @@

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

Smoke::Index class_index, const char* method_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);

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

+

if(m->index > 0)

m->index = m->smoke->methodMaps[m->index].method;

}

@@ -223,7 +222,7 @@

/** Casts an object.

* @param smoke the Smoke module

- * @param object the objec

+ * @param object the object

* @param from the class index of @a object

* @param to the class index to cast to

*

--- old-smoke/src/libsmoke/smoke.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/libsmoke/smoke.lisp 2014-10-20 04:28:15.000000000 +0200

@@ -1,20 +1,16 @@

(in-package #:smoke)

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

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

- (define-foreign-library libsmokeqt

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

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

(define-foreign-library libclsmoke

+ (:darwin "libclsmoke.dylib")

(:unix "libclsmoke.so")

(t (:default "libclsmoke")))

(define-foreign-library libclsmokeutil

+ (:darwin "libclsmokeutil.dylib")

(:unix "libclsmokeutil.so")

(t (:default "libclsmokeutil")))

- (use-foreign-library libsmokeqt)

(use-foreign-library libclsmoke))

-

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

(use-foreign-library libclsmokeutil)

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

@@ -41,12 +37,11 @@

"Smoke index."

`(integer ,lower ,upper))

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

- (smoke :pointer)

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

(destruct :pointer)

(dispatch :pointer))

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

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

(smoke smoke-binding))

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

@@ -55,10 +50,6 @@

(smoke :pointer)

(index smoke-index))

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

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

- (smoke-binding smoke-binding))

-

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

(smoke :pointer))

--- old-smoke/src/libsmoke/smokebinding.cpp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/libsmoke/smokebinding.cpp 2014-10-20 04:28:15.000000000 +0200

@@ -6,18 +6,65 @@

namespace cl_smoke

{

-/** @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

* Callback when a Smoke object is destructed.

*

* @param class_index Index of the object's class.

* @param object pointer to the object

*/

+/** Constructor.

+ * @param destruct destruct callback

+ */

+NoDispatchBinding::NoDispatchBinding(destructed destruct)

+ : SmokeBinding(NULL),

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

+{

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

+}

+

+/** @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.

+ */

/** @typedef Binding::dispatch_method

* Callback when a Smoke method gets called.

@@ -33,55 +80,26 @@

*/

/** Constructor.

- * @param smoke the Smoke module

* @param destruct destruct callback

* @param dispatch method dispatch callback

*/

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

- dispatch_method dispatch)

- : SmokeBinding(smoke),

- destruct(destruct),

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

+ : NoDispatchBinding(destruct),

dispatch(dispatch)

{

- Q_ASSERT(smoke);

- Q_ASSERT(destruct);

Q_ASSERT(dispatch);

}

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

-void

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

-{

- destruct(object);

-}

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

bool

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

Smoke::Stack stack, bool abstract)

{

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

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

Q_ASSERT( !abstract || ret );

return ret;

}

-/**

- * @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;

-}

-

} // namespace cl_smoke

--- old-smoke/src/libsmoke/smokebinding.h 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/libsmoke/smokebinding.h 2014-10-20 04:28:15.000000000 +0200

@@ -6,15 +6,12 @@

namespace cl_smoke

{

-class Binding : public SmokeBinding

+class NoDispatchBinding : public SmokeBinding

{

public:

typedef void (*destructed)(void* object);

- 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(destructed destruct);

virtual void

deleted(Smoke::Index classId, void *object);

@@ -26,11 +23,25 @@

virtual char*

className(Smoke::Index classId);

- Smoke*

- get_smoke() const;

-

private:

const destructed destruct;

+};

+

+class Binding : public NoDispatchBinding

+{

+ public:

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

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

+

+ Binding(destructed destruct, dispatch_method dispatch);

+

+

+ virtual bool

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

+ Smoke::Stack stack, bool abstract);

+

+

+ private:

const dispatch_method dispatch;

};

--- old-smoke/src/objects/class.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/objects/class.lisp 2014-10-20 04:28:15.000000000 +0200

@@ -30,6 +30,11 @@

(defmethod name ((class smoke-class))

(class-slot-value class 'name))

+(defun name-pointer (class)

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

+ 'smoke-class 'name)

+ :pointer))

+

(defun class-size (smoke-class)

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

@@ -107,8 +112,7 @@

(defun real-class (class)

"Returns the same class like CLASS, but such that EXTERNAL-P returns NIL."

(if (external-p class)

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

- (undefined-class () class))

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

class))

(defun class-id (module class)

@@ -117,12 +121,11 @@

(id class)

(smoke-class-id module (name class))))

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

(defun derived-p (class base-class)

"Returns T when CLASS is derived from BASE-CLASS and NIL when not."

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

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

(smoke-is-derived-from (smoke-module-pointer (smoke class))

--- old-smoke/src/objects/stack.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/objects/stack.lisp 2014-10-20 04:28:15.000000000 +0200

@@ -112,8 +112,9 @@

(when (stack-p type)

(funcall (cdr translation) pointer))))

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

+ (cerror "Return the pointer"

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

+ type))))

(1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))

(2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))

(3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))

@@ -139,13 +140,17 @@

(let ((class (get-class type)))

(if (has-pointer-p object)

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

- (get-class type))

+ (get-class type))

(get-object object)

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

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

(instance-to-lisp object (find-smoke-class class) type)))

(instance-to-lisp object (find-smoke-class class) type))))

--- old-smoke/src/objects/type.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/objects/type.lisp 2014-10-20 04:28:15.000000000 +0200

@@ -119,14 +119,15 @@

;; For efficiency 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)))

+ (declare (optimize (speed 3)))

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

+ (foreign-slot-pointer

+ (mem-aref (smoke-array-pointer

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

+ 'smoke-type

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

+ 'smoke-type 'name)

+ :pointer)))

(defgeneric get-class (smoke-symbol)

--- old-smoke/src/overload-resolution.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/overload-resolution.lisp 2014-10-20 04:28:14.000000000 +0200

@@ -195,24 +195,27 @@

conversion2

conversion1)))

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

-

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

&rest args)

- `(,(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)))

(defun+using-type get-conversion-sequence object (object type &optional user)

"Retrains a conversion sequence to convert a instance of type CLASS

@@ -304,7 +307,11 @@

collect `(setf (gethash ,type-name *from-lisp-translations*)

#'(lambda (type type-p)

(and (if type-p

- (subtypep type ',lisp-type)

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

+ (subtypep type ',lisp-type)

+ (unless valid-p

+ (throw 'unspecific-type type))

+ value)

(typep type ',lisp-type))

',conversion-function-name))))))

@@ -333,12 +340,16 @@

(5 (object.typep '(c-integer :unsigned-short)))

(6 (object.typep '(c-integer :int)))

(7 (object.typep '(c-integer :unsigned-int)))

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

(10 (object.typep 'single-float))

(11 (object.typep 'double-float))

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

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

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

@@ -358,7 +369,7 @@

(defun coerce-c-string (string)

(make-auto-pointer (foreign-string-alloc string)))

-(defun coerce-enum (enum)

+(defun coerce-from-enum (enum)

(cxx-support:value enum))

(defun coerce-double-float (number)

@@ -367,6 +378,11 @@

(defun coerce-single-float (number)

(float number 0f0))

+(defun coerce-to-enum (number)

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

+ ;; point.

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

+

;; FIXME incomplete

(defun+using-type promotion object (object type)

(declare (smoke-type type))

@@ -375,13 +391,15 @@

(object.typep 'string))

(make-match 'promotion 'coerce-c-string)))

(6 (when (object.typep 'enum)

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

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

(7 (when (object.typep 'enum)

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

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

(10 (when (object.typep 'real)

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

(11 (when (object.typep 'real)

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

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

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

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

(declaim (inline coerce-to-class))

(defun coerce-cast (object to-class)

@@ -511,25 +529,77 @@

(condition-class condition)

(condition-arguments condition)))))

-

(defun call-using-args (object-or-class name arguments)

"Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."

(declare (optimize (speed 3))

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

object-or-class))

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

+ (#-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)))

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

+ (apply #'call-sequence method

+ (if (static-p method)

+ (null-pointer)

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

+ sequence arguments)))

+

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

+

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

+ (let ((method (find-smoke-method class (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))))))))

--- old-smoke/src/sb-optimize.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/sb-optimize.lisp 2014-10-20 04:28:14.000000000 +0200

@@ -92,23 +92,38 @@

sequence argument-names)))))))))))

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

+;;; Cache overload resolution / method lookup

+

+;;; FIXME the cached lookup should be faster

+;;;

+;;; 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.

;;;

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

+;;; 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

:hash-function (lambda (name arguments

class const-p)

(declare (string name)

(list arguments)

- (class class)

+ (sb-c::layout class)

(boolean const-p))

(logand

(logxor

(sxhash name)

- (sxhash arguments)

+ (the fixnum

+ (reduce

+ #'logxor

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

+ arguments)))

(sxhash class)

(sxhash const-p))

#x1FF))

@@ -117,25 +132,28 @@

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

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

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

+ class const-p)

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

(if (symbolp s)

(fdefinition s)

#'(lambda (x)

+ (declare (optimize (speed 3)))

(funcall (fdefinition (first s))

x

- (second s)))))

+ (eval (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

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

name

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

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

class

const-p))))

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

--- old-smoke/src/smoke-to-clos.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/smoke-to-clos.lisp 2014-10-20 04:28:14.000000000 +0200

@@ -138,8 +138,9 @@

(unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))

(setf (gethash (lispify name :cxx) setf-function-symbols) t)

(push (setf-method-definition method) functions)))

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

(when (static-p method)

(let* ((function-symbol (static-method-symbol package method))

(methods (gethash function-symbol function-symbols)))

--- old-smoke/src/smoke.lisp 2014-10-20 04:28:14.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-10-20 04:28:14.000000000 +0200

@@ -73,38 +73,43 @@

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

(defun delete-object (object)

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

(setf (slot-value object 'pointer) (null-pointer)))

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

+

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

+ *binding*

+ *no-dispatch-binding*))

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

(defun init (smoke module)

"Returns the a new Smoke binding for the Smoke module SMOKE."

(use-foreign-library libclsmoke)

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

- (callback dispatch-method))))

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

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

(let ((pointer-symbol-map (make-hash-table)))

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

@@ -172,6 +177,7 @@

`(progn

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

(define-foreign-library ,library

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

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

(t (:default ,(format nil "~(~A~)" library)))))

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