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

* Use libsmokebase instead of libsmokeqtcore.

-find_library(smokeqtcore_LIB smokeqtcore)

-if (smokeqtcore_LIB)

- set(smokeqtcore_FOUND TRUE)

-endif (smokeqtcore_LIB)

+find_library(smokebase_LIB smokebase)

+if (smokebase_LIB)

+ set(smokebase_FOUND TRUE)

+endif (smokebase_LIB)

-if (smokeqtcore_FOUND)

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

-else (smokeqtcore_FOUND)

- message(FATAL_ERROR "Could not find smokeqtcore")

-endif (smokeqtcore_FOUND)

+if (smokebase_FOUND)

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

+else (smokebase_FOUND)

+ message(FATAL_ERROR "Could not find smokebase")

+endif (smokebase_FOUND)

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

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

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

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

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

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

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

+ (call-next-method)

+ (ecase operation

+ (setf [_$_]

+ (handler-case (funcall (fdefinition

+ (intern

+ (concatenate 'string "SET-"

+ (string-upcase

+ (string slot-name)))

+ :cxx))

+ class new-value)

+ (undefined-function ()

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

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

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

+ (length (condition-arguments condition))

+ (condition-class condition)))

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

+ (error condition)))))

+ (slot-boundp t)

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

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

+

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

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

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

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

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

- (get-class type))

+ (get-class type))

- (cerror "Remove the old object."

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

- object (get-object object) type)

- (remove-object object)

+ (when (stack-p type)

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

+ ;; same address as its object.

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

+ (cerror "Remove the old object."

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

+ object (get-object object) type)

+ (remove-object object))

-

+

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

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

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

+ (call-next-method)

+ (ecase operation

+ (setf [_$_]

+ (handler-case (funcall (fdefinition

+ (intern

+ (concatenate 'string "SET-"

+ (string-upcase

+ (string slot-name)))

+ :cxx))

+ object new-value)

+ (undefined-function ()

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

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

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

+ (length (condition-arguments condition))

+ (condition-class condition)))

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

+ (error condition)))))

+ (slot-boundp t)

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

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

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

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

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

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

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

- name))

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

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

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

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

* Improve missing to-lisp-translator error message.

- (cerror "Return the pointer"

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

+ (cerror "Return the pointer"

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

+ type))))

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

* Allow passing integers as enum arguments.

-(defun coerce-enum (enum)

+(defun coerce-from-enum (enum)

+(defun coerce-to-enum (number)

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

+ ;; point.

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

+

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

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

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

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

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

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

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

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

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

* Fix overload resolution exact match for long and ulong.

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

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

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

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

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

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

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

* Faster no overload resolution method lookup.

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

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

+

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

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

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

* Cache overload resolution on sbcl

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

- arguments

- class)

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

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

+ (constructor-name class)

+ arguments

+ class nil)

+ (declare (optimize (speed 3)))

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

- (mem-aref (smoke-array-pointer

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

- 'smoke-type

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

- 'smoke-type 'name)

- :pointer)))

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

+ (mem-aref (smoke-array-pointer

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

+ 'smoke-type

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

+ 'smoke-type 'name)

+ :pointer)))

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

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

- (if arg

- `(if (using-typep)

- `(,,name

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

- #'(lambda (object)

- (funcall (fdefinition ,name)

- object ,arg)))

- `(if (using-typep)

- ,name

- (fdefinition ,name)))))

-

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

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

- ,@args))

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

+ (if arg

+ `(if (using-typep)

+ `(,,name

+ ,(if (typep ,arg 'class)

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

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

+ (find-smoke-class

+ (get-class ,arg))))

+ ,(name ,arg))))

+ #'(lambda (object)

+ (funcall (fdefinition ,name)

+ object ,arg)))

+ `(if (using-typep)

+ ,name

+ (fdefinition ,name)))))

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

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

+ ,@args)))

- (subtypep type ',lisp-type)

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

+ (subtypep type ',lisp-type)

+ (unless valid-p

+ (throw 'unspecific-type type))

+ value)

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

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

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

+ (when (using-typep)

+ (throw 'unspecific-type object))

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

- (find-best-viable-function name

- arguments

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

- (when (typep object-or-class

- 'smoke-standard-object)

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

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

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

+ name

+ arguments

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

+ (when (typep object-or-class

+ 'smoke-standard-object)

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

- (if (static-p method)

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

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

- sequence arguments))))

+ (apply #'call-sequence method

+ (if (static-p method)

+ (null-pointer)

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

+ sequence arguments)))

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

+;;; Cache overload resolution / method lookup

+

+;;; FIXME the cached lookup should be faster

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

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

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

+;;; cache return value conversion

+;;;

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

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

+;;;

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

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

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

+;;;

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

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

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

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

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

- (class class)

+ (sb-c::layout class)

- (sxhash arguments)

+ (the fixnum

+ (reduce [_$_]

+ #'logxor

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

+ arguments)))

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

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

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

+ class const-p)

+ (declare (optimize (speed 3)))

- (second s)))))

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

- [_$_]

+

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

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

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

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

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

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

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

+ (declare (optimize (speed 3)))

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

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

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

- (name class))))

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

+ name)))

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

- (s-call

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

- (pointer object)))

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

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

* No need to construct a SmokeBinding per Smoke module.

-

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

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

- ((binding :pointer)

- (method smoke-index)

+ ((method smoke-index)

- :smoke (gethash (pointer-address

- (smoke-get-smoke binding))

- *smoke-modules*)

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

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

- * @related cl_smoke::Binding

- * @param binding the Binding

- *

- * @return the Smoke module

- */

-CL_SMOKE_EXPORT void*

-cl_smoke_get_smoke(smoke_binding binding)

-{

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

-}

-

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

+cl_smoke_construct_binding(void* destruct, void* dispatch)

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

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

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

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

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

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

- * @param smoke the smoke binding

+ * @param smoke the smoke module

- (smoke :pointer)

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

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

- (smoke-binding smoke-binding))

-

- * @param smoke the Smoke module

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

- : SmokeBinding(smoke),

+NoDispatchBinding::NoDispatchBinding(destructed destruct)

+ : SmokeBinding(NULL),

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

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

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

- * @param smoke the Smoke module

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

- dispatch_method dispatch)

- : NoDispatchBinding(smoke, destruct),

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

+ : NoDispatchBinding(destruct),

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

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

- NoDispatchBinding(Smoke *smoke, destructed destruct);

+ NoDispatchBinding(destructed destruct);

- Smoke*

- get_smoke() const

- { return smoke; }

-

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

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

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

+ Binding(destructed destruct, dispatch_method dispatch);

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

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

+ (callback destructed)

+ (callback dispatch-method)))

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

+ (callback destructed)

+ (null-pointer))))

+

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

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

+ *binding*

+ *no-dispatch-binding*))

- (let ((no-dispatch-binding

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

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

- (callback dispatch-method))))

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

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

- (smoke-module-binding module) binding)

- (init-smoke-module module)

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

- module))

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

+ (init-smoke-module module)

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

+ module)