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. diff -rN -u old-smoke/src/bindings.lisp new-smoke/src/bindings.lisp --- old-smoke/src/bindings.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/bindings.lisp 2014-10-05 10:08:59.000000000 +0200 @@ -5,11 +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) - (no-dispatch-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/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-05 10:08:59.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)) @@ -349,9 +348,7 @@ ;; the finalizer. Thus OBJECT might be NIL. (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 @@ -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)) diff -rN -u old-smoke/src/libsmoke/CMakeLists.txt new-smoke/src/libsmoke/CMakeLists.txt --- old-smoke/src/libsmoke/CMakeLists.txt 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/libsmoke/CMakeLists.txt 2014-10-05 10:08:59.000000000 +0200 @@ -10,21 +10,21 @@ # 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) +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 SHARED ${SMOKE_C_SOURCES}) -target_link_libraries(clsmoke ${QT_LIBRARIES} ${smokeqtcore_LIB}) +target_link_libraries(clsmoke ${QT_LIBRARIES} ${smokebase_LIB}) set_target_properties(clsmoke PROPERTIES SOVERSION "0.0" diff -rN -u old-smoke/src/libsmoke/smoke.cpp new-smoke/src/libsmoke/smoke.cpp --- old-smoke/src/libsmoke/smoke.cpp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/libsmoke/smoke.cpp 2014-10-05 10:08:59.000000000 +0200 @@ -12,18 +12,6 @@ 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 static_cast(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. @@ -37,14 +25,12 @@ * @return a pointer to a new Smoke binding. */ CL_SMOKE_EXPORT smoke_binding -cl_smoke_construct_binding(void* smoke, void* destruct, void* dispatch) +cl_smoke_construct_binding(void* destruct, void* dispatch) { if (NULL == dispatch) - return new NoDispatchBinding(static_cast(smoke), - reinterpret_cast(destruct)); + return new NoDispatchBinding(reinterpret_cast(destruct)); else - return new Binding(static_cast(smoke), - reinterpret_cast(destruct), + return new Binding(reinterpret_cast(destruct), reinterpret_cast(dispatch)); } @@ -198,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 */ @@ -209,7 +195,10 @@ 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); + 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; diff -rN -u old-smoke/src/libsmoke/smoke.lisp new-smoke/src/libsmoke/smoke.lisp --- old-smoke/src/libsmoke/smoke.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/libsmoke/smoke.lisp 2014-10-05 10:08:59.000000000 +0200 @@ -38,7 +38,6 @@ `(integer ,lower ,upper)) (defcfun (smoke-construct-binding "cl_smoke_construct_binding") smoke-binding - (smoke :pointer) (destruct :pointer) (dispatch :pointer)) @@ -51,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 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/libsmoke/smokebinding.cpp 2014-10-05 10:08:59.000000000 +0200 @@ -23,11 +23,10 @@ */ /** Constructor. - * @param smoke the Smoke module * @param destruct destruct callback */ -NoDispatchBinding::NoDispatchBinding(Smoke *smoke, destructed destruct) - : SmokeBinding(smoke), +NoDispatchBinding::NoDispatchBinding(destructed destruct) + : SmokeBinding(NULL), destruct(destruct) { Q_ASSERT(destruct); @@ -55,8 +54,7 @@ char* NoDispatchBinding::className(Smoke::Index classId) { - Q_ASSERT(classId >= 0 && classId <= smoke->numClasses); - return const_cast(smoke->classes[classId].className); + qFatal("className() Not implemented"); } /** @function NoDispatchBinding::get_smoke() @@ -82,13 +80,11 @@ */ /** Constructor. - * @param smoke the Smoke module * @param destruct destruct callback * @param dispatch method dispatch callback */ -Binding::Binding(Smoke *smoke, destructed destruct, - dispatch_method dispatch) - : NoDispatchBinding(smoke, destruct), +Binding::Binding(destructed destruct, dispatch_method dispatch) + : NoDispatchBinding(destruct), dispatch(dispatch) { Q_ASSERT(dispatch); @@ -100,7 +96,7 @@ 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; diff -rN -u old-smoke/src/libsmoke/smokebinding.h new-smoke/src/libsmoke/smokebinding.h --- old-smoke/src/libsmoke/smokebinding.h 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/libsmoke/smokebinding.h 2014-10-05 10:08:59.000000000 +0200 @@ -11,7 +11,7 @@ public: typedef void (*destructed)(void* object); - NoDispatchBinding(Smoke *smoke, destructed destruct); + NoDispatchBinding(destructed destruct); virtual void deleted(Smoke::Index classId, void *object); @@ -23,10 +23,6 @@ virtual char* className(Smoke::Index classId); - Smoke* - get_smoke() const - { return smoke; } - private: const destructed destruct; }; @@ -34,10 +30,10 @@ class Binding : public NoDispatchBinding { public: - typedef int (*dispatch_method)(Binding* binding, Smoke::Index method, + typedef int (*dispatch_method)(Smoke::Index method, void* object, Smoke::Stack args, int abstract); - Binding(Smoke *smoke, destructed destruct, dispatch_method dispatch); + Binding(destructed destruct, dispatch_method dispatch); virtual bool diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp --- old-smoke/src/objects/stack.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/objects/stack.lisp 2014-10-05 10:08:59.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)))) diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp --- old-smoke/src/objects/type.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/objects/type.lisp 2014-10-05 10:08:59.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) diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp --- old-smoke/src/overload-resolution.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/overload-resolution.lisp 2014-10-05 10:08:59.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)))))))) diff -rN -u old-smoke/src/sb-optimize.lisp new-smoke/src/sb-optimize.lisp --- old-smoke/src/sb-optimize.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/sb-optimize.lisp 2014-10-05 10:08:59.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)) diff -rN -u old-smoke/src/smoke-to-clos.lisp new-smoke/src/smoke-to-clos.lisp --- old-smoke/src/smoke-to-clos.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/smoke-to-clos.lisp 2014-10-05 10:08:59.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))) diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2014-10-05 10:08:59.000000000 +0200 +++ new-smoke/src/smoke.lisp 2014-10-05 10:08:59.000000000 +0200 @@ -73,12 +73,17 @@ (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))) @@ -87,8 +92,8 @@ (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)))) + *binding* + *no-dispatch-binding*)) (foreign-funcall-pointer (foreign-slot-value (smoke-class-pointer class) 'smoke-class 'class-function) @@ -101,16 +106,10 @@ (defun init (smoke module) "Returns the a new Smoke binding for the Smoke module SMOKE." (use-foreign-library libclsmoke) - (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) (let ((pointer-symbol-map (make-hash-table))) ;; Used by make-load-form for enums to reference the smoke module.