Tue Jul 13 21:17:41 CEST 2010 Tobias Rautenkranz * Use libsmokebase instead of libsmokeqtcore. Sat Apr 3 21:11:26 CEST 2010 Tobias Rautenkranz * slot-value access for static attributes using the class instead of an object. Sat Apr 3 14:04:39 CEST 2010 Tobias Rautenkranz * 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 * 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 * Improve missing to-lisp-translator error message. Sat Feb 20 21:56:27 CET 2010 Tobias Rautenkranz * Allow passing integers as enum arguments. Sat Feb 20 19:01:21 CET 2010 Tobias Rautenkranz * Fix overload resolution exact match for long and ulong. Sat Feb 20 18:56:48 CET 2010 Tobias Rautenkranz * Faster no overload resolution method lookup. Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz * Cache overload resolution on sbcl Fri Feb 19 22:22:50 CET 2010 Tobias Rautenkranz * cleanup #'delete-object & optimize #'constructor-name. Fri Feb 19 22:10:24 CET 2010 Tobias Rautenkranz * No need to construct a SmokeBinding per Smoke module. Thu Feb 18 20:57:00 CET 2010 Tobias Rautenkranz * Don't dispatch virtual methods for builtin classes (reduces overhead). Thu Feb 18 19:31:47 CET 2010 Tobias Rautenkranz * Fix casting across Smoke modules. Wed Feb 17 18:05:35 CET 2010 Tobias Rautenkranz * 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 * Load libsmokeqtcore instead of qt in the default case of cffi:define-foreign-library. Tue Feb 16 22:52:02 CET 2010 Tobias Rautenkranz * Fix derived-p for classes that are external in every module. Mon Feb 15 16:31:33 CET 2010 Tobias Rautenkranz * Build a shared library not a module. Fixes on build error on OS X as reported by Elliott Slaughter. Mon Feb 8 18:14:54 CET 2010 Tobias Rautenkranz * sbcl-bundle requires posix & unix Thu Feb 4 16:11:29 CET 2010 Tobias Rautenkranz * Test building libclsmoke. Wed Feb 3 17:20:56 CET 2010 Tobias Rautenkranz * Fix compiling libclsmoke with asserts enabled. smoke_get_class was not declared in this scope Reported by: Elliott Slaughter Wed Feb 3 07:44:09 CET 2010 Tobias Rautenkranz * Add missing :sb-posix dependency. Sat Jan 30 15:40:08 CET 2010 Tobias Rautenkranz * Do not warn on missing parent class. Tue Jan 26 17:26:09 CET 2010 Tobias Rautenkranz * Fix for r1077826. Not instantiable parent classes are external. (QAbstractPrintDialog) Mon Jan 25 19:47:00 CET 2010 Tobias Rautenkranz * Check enum type on overload resolution Mon Jan 25 19:46:41 CET 2010 Tobias Rautenkranz * single-float conversion Mon Jan 25 19:41:22 CET 2010 Tobias Rautenkranz * Add :arg3 for make-instance SMOKE-CLASS. Sat Jan 23 20:45:41 CET 2010 Tobias Rautenkranz * class & type size (and some more exports) Sun Jan 17 22:04:08 CET 2010 Tobias Rautenkranz * 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). Sun Jan 10 18:31:42 CET 2010 Tobias Rautenkranz * Fix overload resolution when a lisp smoke module is not loaded. Sun Jan 10 18:30:48 CET 2010 Tobias Rautenkranz * Auto-recompile when the smoke module has changed. diff -rN -u old-smoke/cl-smoke.smoke.asd new-smoke/cl-smoke.smoke.asd --- old-smoke/cl-smoke.smoke.asd 2015-10-03 06:21:20.249289472 +0200 +++ new-smoke/cl-smoke.smoke.asd 2015-10-03 06:21:20.284287046 +0200 @@ -6,7 +6,8 @@ :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) + (:cffi :closer-mop :alexandria :trivial-garbage :bordeaux-threads + #+(and sbcl unix) :sb-posix) :components ((:module :src :components @@ -44,7 +45,7 @@ :depends-on ("package") :components ((:file "get-value") - #+sbcl (:file "sbcl-bundle") + #+(and sbcl unix) (:file "sbcl-bundle") (:module :image :components ((:file "image" :depends-on (:impl)) (:module :impl @@ -54,9 +55,6 @@ #+(not (or sbcl openmcl)) (:file "not-implemented"))))))))))) -(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)) diff -rN -u old-smoke/src/bindings.lisp new-smoke/src/bindings.lisp --- old-smoke/src/bindings.lisp 2015-10-03 06:21:20.177294461 +0200 +++ new-smoke/src/bindings.lisp 2015-10-03 06:21:20.317284760 +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) diff -rN -u old-smoke/src/class-map.lisp new-smoke/src/class-map.lisp --- old-smoke/src/class-map.lisp 2015-10-03 06:21:20.245289749 +0200 +++ new-smoke/src/class-map.lisp 2015-10-03 06:21:20.319284621 +0200 @@ -8,9 +8,7 @@ (defun id-class-map (smoke) (let ((value (gethash (pointer-address (smoke-module-pointer smoke)) *smoke-id-class-map*))) - (assert value () - "Unknown smoke module ~A ~A." - smoke (smoke-get-module-name (smoke-module-pointer smoke))) + (assert value () "Unknown smoke module ~A." smoke) value)) (defun (setf id-class-map) (new-value smoke) diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2015-10-03 06:21:20.227290996 +0200 +++ new-smoke/src/clos.lisp 2015-10-03 06:21:20.345282819 +0200 @@ -193,11 +193,14 @@ (defmethod initialize-instance :around ((class cxx:class) &rest args) (apply #'init-cxx-class class #'call-next-method args)) -(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))) + (when real-class + (push (class-name real-class) class-symbols))) + (push (lispify (name class)) class-symbols))))) (defun make-smoke-classes (package smoke) "Constructs a lisp class in PACKAGE for each one in the Smoke module SMOKE." @@ -219,8 +222,8 @@ (add-id class (closer-mop:ensure-class class-name :direct-superclasses - (mapcar #'smoke-class-symbol - (smoke-class-direct-superclasses class)) + (smoke-class-symbols + (smoke-class-direct-superclasses class)) :id (id class) :smoke (smoke class) :metaclass 'smoke-standard-class)) @@ -334,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)) @@ -344,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 @@ -428,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) @@ -452,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)) @@ -475,6 +479,7 @@ (arg0 nil arg0p) (arg1 nil arg1p) (arg2 nil arg2p) + (arg3 nil arg3p) &allow-other-keys) "Initializes a Smoke object. Calls its constructor with the arguments supplied by the key :ARGS and sets the smoke binding." @@ -489,6 +494,7 @@ (setf (slot-value object 'pointer) (call-constructor (class-of object) (cond + (arg3p (list arg0 arg1 arg2 arg3)) (arg2p (list arg0 arg1 arg2)) (arg1p (list arg0 arg1)) (t (list arg0))))) diff -rN -u old-smoke/src/libsmoke/CMakeLists.txt new-smoke/src/libsmoke/CMakeLists.txt --- old-smoke/src/libsmoke/CMakeLists.txt 2015-10-03 06:21:20.206292451 +0200 +++ new-smoke/src/libsmoke/CMakeLists.txt 2015-10-03 06:21:20.441276167 +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) diff -rN -u old-smoke/src/libsmoke/cl_smoke.h new-smoke/src/libsmoke/cl_smoke.h --- old-smoke/src/libsmoke/cl_smoke.h 2015-10-03 06:21:20.176294530 +0200 +++ new-smoke/src/libsmoke/cl_smoke.h 2015-10-03 06:21:20.463274642 +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); -} - /** Casts the void pointer smoke to the Smoke class. * @param smoke the Smoke module * diff -rN -u old-smoke/src/libsmoke/class.lisp new-smoke/src/libsmoke/class.lisp --- old-smoke/src/libsmoke/class.lisp 2015-10-03 06:21:20.245289749 +0200 +++ new-smoke/src/libsmoke/class.lisp 2015-10-03 06:21:20.472274019 +0200 @@ -5,6 +5,7 @@ (:constructor #x01) (:copy-constructor #x02) (:virtual-destructor #x04) + (:namespace #x08) (:undefined #x10)) (defcstruct smoke-class @@ -19,9 +20,9 @@ (defcfun (smoke-find-class "cl_smoke_find_class") :void (m :pointer smoke-module-index) - (smoke :pointer) (name :string)) +(declaim (inline smoke-class-id)) (defcfun (smoke-class-id "cl_smoke_class_id") smoke-index (smoke :pointer) (name :string)) diff -rN -u old-smoke/src/libsmoke/smoke.cpp new-smoke/src/libsmoke/smoke.cpp --- old-smoke/src/libsmoke/smoke.cpp 2015-10-03 06:21:20.243289887 +0200 +++ new-smoke/src/libsmoke/smoke.cpp 2015-10-03 06:21:20.491272702 +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), - reinterpret_cast(destruct), - reinterpret_cast(dispatch)); + if (NULL == dispatch) + return new NoDispatchBinding(reinterpret_cast(destruct)); + else + return new Binding(reinterpret_cast(destruct), + reinterpret_cast(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(binding); } -/** Gets a Smoke modules name. +/** Gets a Smoke module name. * @param smoke the Smoke module * * @return the module name @@ -130,13 +123,12 @@ /** Finds a class. * @param c pointer to write the result to - * @param smoke the smoke module * @param name the name of the class */ CL_SMOKE_EXPORT void -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); } /** Gets the class ID for a Smoke module. @@ -179,10 +171,10 @@ cl_smoke_is_derived_from(void* smoke, Smoke::Index class_index, void* smoke_base, Smoke::Index base_index) { - 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); - return get_smoke(smoke)->isDerivedFrom(get_smoke(smoke), class_index, + return Smoke::isDerivedFrom(get_smoke(smoke), class_index, get_smoke(smoke_base), base_index); } @@ -192,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 */ @@ -200,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; } @@ -224,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 * diff -rN -u old-smoke/src/libsmoke/smoke.lisp new-smoke/src/libsmoke/smoke.lisp --- old-smoke/src/libsmoke/smoke.lisp 2015-10-03 06:21:20.201292798 +0200 +++ new-smoke/src/libsmoke/smoke.lisp 2015-10-03 06:21:20.499272148 +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)) diff -rN -u old-smoke/src/libsmoke/smokebinding.cpp new-smoke/src/libsmoke/smokebinding.cpp --- old-smoke/src/libsmoke/smokebinding.cpp 2015-10-03 06:21:20.147296540 +0200 +++ new-smoke/src/libsmoke/smokebinding.cpp 2015-10-03 06:21:20.518270831 +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(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 diff -rN -u old-smoke/src/libsmoke/smokebinding.h new-smoke/src/libsmoke/smokebinding.h --- old-smoke/src/libsmoke/smokebinding.h 2015-10-03 06:21:20.138297163 +0200 +++ new-smoke/src/libsmoke/smokebinding.h 2015-10-03 06:21:20.524270415 +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; }; diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp --- old-smoke/src/objects/class.lisp 2015-10-03 06:21:20.247289610 +0200 +++ new-smoke/src/objects/class.lisp 2015-10-03 06:21:20.532269861 +0200 @@ -30,6 +30,14 @@ (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)) + (defun map-classes (function smoke) "Applies FUNCTION to the classes of SMOKE." (declare (function function) @@ -56,43 +64,55 @@ "Returns T when CLASS has a constructor; NIL otherwise." (/= 0 (get-class-flag class :constructor))) +(defun copy-constructor-p (class) + (/= 0 (get-class-flag class :copy-constructor))) + (defun virtual-destructor-p (class) "Returns T when CLASS has a virtual destructor and NIL otherwise." (/= 0 (get-class-flag class :virtual-destructor))) (define-condition undefined-class (cell-error) - ((smoke-name :initarg :smoke-name - :initform nil - :documentation "The name of the Smoke module")) + () (:report (lambda (condition stream) - (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)))) (:documentation "A undefined Smoke class")) -(defun make-smoke-class (smoke name) - "Returns the class named NAME of the smoke module SMOKE. +(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))))) + +(defun make-smoke-class (name) + "Returns the class named NAME. Signals an undefined-class condition when there is no class for NAME." (with-foreign-object (c 'smoke-module-index) (do () (nil) - (smoke-find-class c (smoke-module-pointer smoke) name) + (smoke-find-class c name) (restart-case (if (null-pointer-p (foreign-slot-value c 'smoke-module-index 'smoke)) - (error (make-condition 'undefined-class :name name :smoke-name (smoke-get-module-name (smoke-module-pointer smoke)))) + (error (make-condition 'undefined-class :name name)) (return)) (supply (new-name) :report "Supply a new class name" :interactive read-new-value (setf name new-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))) (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 (smoke class) (name class)) - (undefined-class () class)) + (make-smoke-class (name class)) class)) (defun class-id (module class) @@ -101,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)) diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp --- old-smoke/src/objects/method.lisp 2015-10-03 06:21:20.234290511 +0200 +++ new-smoke/src/objects/method.lisp 2015-10-03 06:21:20.567267436 +0200 @@ -17,7 +17,8 @@ (if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method))) (null-pointer-p (smoke-method-pointer smoke-method))) - (call-next-method) + (print-unreadable-object (smoke-method stream :type t) + (princ "no method" stream)) (print-unreadable-object (smoke-method stream :type t) (princ (method-declaration smoke-method) stream)))) @@ -136,7 +137,8 @@ "public")) (defun modifiers (method) - (format nil "~A~:[~; static~]" (access method) (static-p method))) + (format nil "~:[~;virtual ~]~A~:[~; static~]" + (virtual-p method) (access method) (static-p method))) (defun return-type (method) "Returns the return type of METHOD." @@ -209,6 +211,10 @@ "Returns T when METHOD is internal and NIL otherwise." (/= 0 (get-method-flag method :internal))) +(defun virtual-p (method) + "Returns T when METHOD is internal and NIL otherwise." + (/= 0 (get-method-flag method :virtual))) + (defmethod get-class ((method smoke-method)) (make-smoke-class-from-id (smoke-method-smoke method) diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp --- old-smoke/src/objects/stack.lisp 2015-10-03 06:21:20.231290719 +0200 +++ new-smoke/src/objects/stack.lisp 2015-10-03 06:21:20.576266812 +0200 @@ -111,7 +111,10 @@ (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))) + (prog1 (foreign-slot-value stack-item 'smoke-stack-item 'voidp) + (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))) @@ -137,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)))) diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp --- old-smoke/src/objects/type.lisp 2015-10-03 06:21:20.231290719 +0200 +++ new-smoke/src/objects/type.lisp 2015-10-03 06:21:20.586266119 +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) @@ -138,3 +139,13 @@ (type) "The type ~S is not a smoke class." type) (make-smoke-class-from-id (smoke type) (type-slot-value type 'class))) + +;; 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)))) diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp --- old-smoke/src/overload-resolution.lisp 2015-10-03 06:21:20.246289680 +0200 +++ new-smoke/src/overload-resolution.lisp 2015-10-03 06:21:20.362281641 +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,11 +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 (object.typep 'enum)) ;; FIXME enum-type + (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)))))) @@ -357,12 +369,20 @@ (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) (float number 0d0)) +(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)) @@ -371,11 +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) @@ -463,17 +487,21 @@ (defun+using-type constructor-conversion object (object type) (when (class-p type) - (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 ())))) (defun call-sequence (method object sequence &rest args) (s-call method object @@ -501,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)))))))) diff -rN -u old-smoke/src/package.lisp new-smoke/src/package.lisp --- old-smoke/src/package.lisp 2015-10-03 06:21:20.230290788 +0200 +++ new-smoke/src/package.lisp 2015-10-03 06:21:20.368281226 +0200 @@ -13,32 +13,56 @@ (defpackage #:smoke (:use #:cl #:cffi #:trivial-garbage #:bordeaux-threads #:cxx-support #:alexandria) - (:export #:init - #:get-smoke-variable-for-pointer - - #:make-smoke-classes - #:eval-startup - - #:delete-object - #:smoke-call - #:call + (:export #:call + #:c-integer - #:name + #:class-p + #:class-size + #:const-p #:id - #:smoke-type= + #:name + #:pointer + #:pointer-p + #:size + #:smoke + #:stack-p + #:type-foreign-keyword + #:type-id + #:type-size + #:virtual-destructor-p + #:convert-argument #:cxx-bool #:define-from-lisp-translation #:define-to-lisp-translation - #:define-pointer-typedef - #:make-cleanup-pointer - #:make-auto-pointer + #:*to-lisp-translations* - #:const-p - #:pointer + #:define-pointer-typedef #:define-smoke-module + #:define-takes-ownership + #:delete-object + #:remove-object + + #:eval-startup + + #:get-smoke-variable-for-pointer + #:init + #:object-to-lisp + + #:make-auto-pointer + #:make-cleanup-pointer + + #:make-smoke-classes + #:make-smoke-type + #:no-applicable-cxx-method + #:smoke-call + #:upcast + + #:smoke-standard-object + #:smoke-type + #:smoke-type= #+sbcl #:save-bundle)) diff -rN -u old-smoke/src/sb-optimize.lisp new-smoke/src/sb-optimize.lisp --- old-smoke/src/sb-optimize.lisp 2015-10-03 06:21:20.090300490 +0200 +++ new-smoke/src/sb-optimize.lisp 2015-10-03 06:21:20.381280325 +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)) diff -rN -u old-smoke/src/smoke-to-clos.lisp new-smoke/src/smoke-to-clos.lisp --- old-smoke/src/smoke-to-clos.lisp 2015-10-03 06:21:20.250289402 +0200 +++ new-smoke/src/smoke-to-clos.lisp 2015-10-03 06:21:20.388279840 +0200 @@ -87,17 +87,21 @@ (eval smoke))))))) (defmacro check-recompile (smoke) - "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))))))))) (defmacro define-classes-and-gfs (package smoke) "Process the C++ methods of the Smoke module SMOKE. @@ -134,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))) @@ -161,8 +166,13 @@ (push export exports)))) `(progn (check-recompile ,smoke) ,@functions + (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)) (eval-when (:load-toplevel :execute) - (make-smoke-classes ,package ,smoke) (ensure-generic-methods ',(hash-table-alist generics))) ,@constants (eval-when (:load-toplevel :execute) diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2015-10-03 06:21:20.233290580 +0200 +++ new-smoke/src/smoke.lisp 2015-10-03 06:21:20.404278731 +0200 @@ -52,11 +52,6 @@ (defun smoke-call (class pointer method-name &optional (args nil)) (s-call (make-smoke-method-from-name class method-name) pointer args)) -(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)) - (defun enum-call (method) "Return the enum value for METHOD." ;; FIXME: @@ -78,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. @@ -177,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) diff -rN -u old-smoke/test.lisp new-smoke/test.lisp --- old-smoke/test.lisp 2015-10-03 06:21:20.216291758 +0200 +++ new-smoke/test.lisp 2015-10-03 06:21:20.297286145 +0200 @@ -1,4 +1,6 @@ #| +cmake ./ || exit 1 +make || exit 1 echo \ "################ ## Testing sbcl