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.

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

* sbcl-bundle requires posix & unix

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

* Test building libclsmoke.

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

* Fix compiling libclsmoke with asserts enabled.

smoke_get_class was not declared in this scope

Reported by:

Elliott Slaughter

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

* Add missing :sb-posix dependency.

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

* Do not warn on missing parent class.

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

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

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

* Check enum type on overload resolution

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

* single-float conversion

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

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

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

* class & type size (and some more exports)

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

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

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

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

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

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

* Auto-recompile when the smoke module has changed.

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

* Support modular smoke & cleanup.

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

* Support ASDF instead of Mudballs.

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

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

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

* Explicitly use old ABI (pre r1045709)

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

* Template types are no longer t_class.

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

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

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

* Various fixes:

* Allow user conversions for return values

* fix destruction of objects with multiple C++ superclasses

* Fix list to QList conversion dispatch

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

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

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

* Allow deriving from multiple C++ classes.

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

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

--- old-smoke/cl-smoke.smoke.asd 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/cl-smoke.smoke.asd 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,60 @@

+(defsystem :cl-smoke.smoke

+ :name :cl-smoke.smoke

+ :version (0 0 1)

+ :author "Tobias Rautenkranz"

+ :license "GPL with linking exception"

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

+implement bindings using the various Smoke modules."

+ :depends-on

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

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

+

+ :components

+ ((:module :src :components

+ ((:file "package")

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

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

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

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

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

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

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

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

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

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

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

+ (:module :objects

+ :serial t

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

+ :components

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

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

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

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

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

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

+ (:module :libsmoke

+ :depends-on ("package")

+ :components

+ ((:file "smoke")

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

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

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

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

+ (:module :utils

+ :depends-on ("package")

+ :components

+ ((:file "get-value")

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

+ (:module :image :components

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

+ (:module :impl

+ :components

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

+ #+openmcl (:file "ccl")

+ #+(not (or sbcl openmcl))

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

+

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

--- old-smoke/smoke.mbd 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/smoke.mbd 1970-01-01 01:00:00.000000000 +0100

@@ -1,78 +0,0 @@

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

-

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

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

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

-(defpackage :sysdef.cmake

- (:use :cl :sysdef)

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

-(in-package :sysdef.cmake)

-

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

- ()

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

-

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

- ((package :initarg :package)))

-;;; end SYDDEF.CMAKE

-

-(in-package :sysdef-user)

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

- (use-package :sysdef.cmake))

-

-(define-system :smoke ()

- (:version 0 0 1)

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

-implement bindings using the various Smoke modules.")

- (:author "Tobias Rautenkranz")

- (:license "GPL with linking exception")

- (:components

- ("CMakeLists" cmake-file)

- (:src module

- (:needs "CMakeLists")

- (:components

- "package"

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

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

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

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

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

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

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

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

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

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

- (:objects module

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

- (:serial t)

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

- "instance" "stack"))

- (:smoke-c module

- (:needs "package")

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

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

-

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

- "libsmoke-c-util"))

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

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

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

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

-

- (:utils module

- (:needs "package")

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

- (:components

- "get-value"

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

- (:image module

- (:components

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

- (:impl module

- (:components

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

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

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

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

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

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

--- old-smoke/src/CMakeLists.txt 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/CMakeLists.txt 2014-10-30 08:11:13.000000000 +0100

@@ -1 +1 @@

-add_subdirectory(smoke-c)

+add_subdirectory(libsmoke)

--- old-smoke/src/bindings.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/bindings.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -1,36 +1,12 @@

(in-package :smoke)

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

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

-

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

-;; load additional modules while threads are running.

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

-

-(defun binding (smoke)

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

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

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

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

- (assert (eql t present-p)

- ()

- "No binding for ~A." smoke)

- value)))

-

-(defun (setf binding) (binding smoke)

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

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

- binding)))

-

(defstruct smoke-array

"A C array."

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

(length 0 :type (smoke-index 0)))

-

(defstruct smoke-module

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

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

(classes (make-smoke-array) :type smoke-array)

(methods (make-smoke-array) :type smoke-array)

@@ -45,6 +21,9 @@

(defvar *smoke-modules* (make-hash-table)

"All loaded Smoke modules.")

+(eval-on-save ()

+ (clrhash *smoke-modules*))

+

(defmethod print-object ((smoke-module smoke-module) stream)

(if (null-pointer-p (smoke-module-pointer smoke-module))

(call-next-method)

--- old-smoke/src/class-map.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/class-map.lisp 2014-10-30 08:11:13.000000000 +0100

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

--- old-smoke/src/clos.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/clos.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -121,6 +121,10 @@

()

(:documentation "Metaclass to extend Smoke Objects."))

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

+ ((extra-objects :reader extra-objects

+ :initarg :extra-objects)))

+

(defmethod closer-mop:validate-superclass ((class smoke-standard-class)

(superclass standard-class))

t)

@@ -147,22 +151,40 @@

(defun init-cxx-class (class next-method &rest args &key direct-superclasses

- &allow-other-keys)

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

(assert (not (null direct-superclasses))

(direct-superclasses)

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

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

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

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

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

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

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

+ (rest direct-superclasses))))

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

((first direct-superclasses))

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

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

+ class)

(assert (virtual-destructor-p superclass)

()

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

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

+ superclass class)

+ (when extra-superclasses

+ (dolist (superclass extra-superclasses)

+ (unless (virtual-destructor-p superclass)

+ (cerror "Continue anyway"

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

+ superclass class)))

+ (setf direct-superclasses

+ (append direct-superclasses

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

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

+ extra-superclasses))

+ direct-default-initargs))

(apply

next-method class

:id (id superclass)

:smoke (smoke superclass)

:direct-superclasses direct-superclasses

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

args)))

(defmethod reinitialize-instance :around ((class cxx:class) &rest args)

@@ -171,36 +193,42 @@

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

(declare (optimize (speed 3)))

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

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

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

(add-id-class-map smoke)

(map-classes

#'(lambda (class)

- (unless (or (external-p class)

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

- (string/= (smoke-get-module-name

- (smoke-module-pointer smoke))

- "qt")

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

+ (unless (external-p class)

(with-simple-restart (skip "Skip generating class ~A" (name class))

- (add-id class

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

- :direct-superclasses

- (mapcar #'smoke-class-symbol

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

- :id (id class)

- :smoke (smoke class)

- :metaclass 'smoke-standard-class))

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

+ (let ((class-name

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

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

+ ;; clashes between multiple modules.

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

+ (lispify "QGlobalSpace" impl-package)

+ (lispify (name class)))))

+ (add-id class

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

+ :direct-superclasses

+ (smoke-class-symbols

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

+ :id (id class)

+ :smoke (smoke class)

+ :metaclass 'smoke-standard-class))

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

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

smoke)))

(defclass smoke-gf (cxx-generic-function)

@@ -246,6 +274,11 @@

;; in a finalizer. In that case the object is already removed from

;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.

(when object

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

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

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

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

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

(remove-finalizer object)

(remove-object object-pointer)

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

@@ -268,42 +301,43 @@

arg)

args))))

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

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

-conversion sequences are considered."

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

- (if (null rank)

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

- argument (name type))

- (funcall (conversion-function-name rank)

- argument))))

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

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

+it is passed on the stack."

+ (flet ((disown (object)

+ (remove-finalizer object)

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

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

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

+ (if (null rank)

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

+ (if (null rank)

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

+ argument (name type))

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

+ argument)))

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

+ (disown ret))

+ ret)))

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

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

+ (disown argument)))))))

(defun put-returnvalue (stack value type object)

(unless (void-p type)

(let ((stack (make-call-stack stack)))

(setf (call-stack-top stack) (call-stack-pointer stack))

- ;; FIXME support user conversions.

- ;;

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

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

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

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

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

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

- (remove-finalizer converted-value)

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

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

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

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

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

(defun get-gf-for-method (smoke-method)

(declare (smoke-method smoke-method)

(optimize (speed 3)))

(symbol-function (lispify (name smoke-method) "CXX")))

-;; Receive virutal function calls.

+;; Receive virtual function calls.

(defcallback dispatch-method :boolean

- ((binding :pointer)

- (method smoke-index)

+ ((method smoke-index)

(object-ptr :pointer)

(stack smoke-stack)

(abstract :boolean))

@@ -312,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

@@ -386,16 +416,30 @@

nil))))

;;FIXME use CHANGE-CLASS instead?

-(defun cast (object class)

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

+(defgeneric cast (object class)

(declare (optimize (speed 3)))

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

- ()

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

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

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

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

-

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

+ (:method (object class)

+ (declare (optimize (speed 3)))

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

+ ()

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

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

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

+ (id (class-of object))

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

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

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

+ (extra-objects object))))

+ (assert extra-object

+ ()

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

+ object (name class))

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

(defun upcast (object class)

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

@@ -408,36 +452,34 @@

;; 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 (object arguments)

- (if (null arguments)

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

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

- (assert (valid-p method)

- (method)

- "No constructor for ~A." object)

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

- (multiple-value-bind (method sequence)

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

- arguments

- (class-of object))

- (when (null method)

- (error "No constructor for object ~A with

-the arguments ~S." object arguments))

- (pointer-call method (null-pointer)

- (mapcar #'(lambda (conversion argument)

- (funcall conversion argument))

- sequence arguments)))))

+(defun call-constructor (class arguments)

+ (multiple-value-bind (method sequence)

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

+ (pointer-call method (null-pointer)

+ (mapcar #'(lambda (conversion argument)

+ (funcall conversion argument))

+ sequence arguments))))

(defmethod initialize-instance :after ((object smoke-standard-object)

&key args

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

@@ -450,16 +492,44 @@

(unless (slot-boundp object 'pointer)

(if arg0p

(setf (slot-value object 'pointer)

- (call-constructor object

+ (call-constructor (class-of object)

(cond

+ (arg3p (list arg0 arg1 arg2 arg3))

(arg2p (list arg0 arg1 arg2))

(arg1p (list arg0 arg1))

(t (list arg0)))))

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

+ (setf (slot-value object 'pointer)

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

(set-binding object)

(take-ownership object)

(add-object object)))

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

+ (loop for class in extra-objects

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

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

+ nil))))

+ (set-binding extra-object)

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

+ extra-object)))

+

+(defmethod initialize-instance :after ((object smoke-multi-superclass-mixin)

+ &key args)

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

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

+

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

+ (let ((pointer (pointer object))

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

+ (class (class-of object)))

+ #'(lambda ()

+ (declare (optimize (speed 3)))

+ (handler-case (progn

+ (delete-pointer pointer class)

+ (dolist (object extra-objects)

+ (delete-object object)))

+ (error (condition)

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

(defmethod instance-to-lisp (pointer class type)

(declare (type smoke-standard-class class)

@@ -475,7 +545,7 @@

(declare (type smoke-standard-object object)

(optimize (speed 3)))

(when (member object (owned-objects new-owner))

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

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

object new-owner))

(push object (owned-objects new-owner)))

--- old-smoke/src/libsmoke/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/CMakeLists.txt 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,39 @@

+find_package(Qt4 REQUIRED)

+set(QT_DONT_USE_QTGUI true)

+include(${QT_USE_FILE})

+

+include(CheckCXXCompilerFlag)

+check_cxx_compiler_flag("-fvisibility=hidden" CXX_VISIBILITY)

+if(CXX_VISIBILITY)

+ 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 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 SHARED smoke_util.cpp)

+set_target_properties(clsmokeutil

+ PROPERTIES

+ SOVERSION "0.0"

+ VERSION "0.0.1")

+

+install(TARGETS clsmoke clsmokeutil DESTINATION lib)

--- old-smoke/src/libsmoke/cl_smoke.h 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/cl_smoke.h 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,50 @@

+#ifndef CL_SMOKE_H

+#define CL_SMOKE_H

+

+#include <smoke.h>

+

+#if defined _WIN32 || defined __CYGWIN__

+ #define CL_SMOKE_EXPORT __declspec(dllexport)

+#else

+ #if __GNUC__ >= 4

+ #define CL_SMOKE_EXPORT __attribute__((visibility("default")))

+ #else

+ #define CL_SMOKE_EXPORT

+ #endif

+#endif

+

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

+namespace cl_smoke

+{

+class Binding;

+

+/** The arrays of the Smoke module */

+enum cl_smoke_module_array

+{

+ classes,

+ methods,

+ method_maps,

+ method_names,

+ types,

+ inheritance_list,

+ argument_list,

+ ambiguous_method_list

+};

+

+/** A Binding */

+typedef void* smoke_binding;

+

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

+ * @param smoke the Smoke module

+ *

+ * @return pointer to the Smoke module.

+ */

+static inline

+Smoke*

+get_smoke(void* smoke)

+{

+ return static_cast<Smoke*>(smoke);

+}

+} // namespace cl_smoke

+

+#endif // CL_SMOKE_H

--- old-smoke/src/libsmoke/class.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/class.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,44 @@

+(in-package #:smoke)

+

+(defcenum smoke-class-flags

+ "Class properties"

+ (:constructor #x01)

+ (:copy-constructor #x02)

+ (:virtual-destructor #x04)

+ (:namespace #x08)

+ (:undefined #x10))

+

+(defcstruct smoke-class

+ "Describe a class"

+ (name :string)

+ (external cxx-bool)

+ (parents smoke-index)

+ (class-function :pointer)

+ (enum-function :pointer)

+ (flags :unsigned-short)

+ (size :unsigned-int))

+

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

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

+

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

+ (smoke :pointer)

+ (class smoke-index))

+

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

+ (smoke :pointer)

+ (class smoke-index)

+ (smoke-base :pointer)

+ (base-class smoke-index))

+

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

+ (smoke :pointer)

+ (object :pointer)

+ (from smoke-index)

+ (to smoke-index))

--- old-smoke/src/libsmoke/method.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/method.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,41 @@

+(in-package #:smoke)

+

+(defcenum smoke-method-flags

+ "Method flags"

+ (:static #x01)

+ (:const #x02)

+ (:copy-constructor #x04)

+ (:internal #x08)

+ (:enum #x10)

+ (:constructor #x20)

+ (:destructor #x40)

+ (:protected #x80)

+ (:attribute #x100)

+ (:property #x200)

+ (:virtual #x400)

+ (:purevirtual #x800)

+ (:signal #x1000)

+ (:slot #x2000))

+

+(defcstruct smoke-method

+ "Describe a method"

+ (class smoke-index)

+ (name smoke-index)

+ (arguments smoke-index)

+ (num-args :unsigned-char)

+ (flags :unsigned-short)

+ (return-type smoke-index)

+ (method smoke-index))

+

+(defcstruct smoke-method-map

+ "Maps a munged method."

+ (class-id smoke-index)

+ (name smoke-index)

+ (method smoke-index))

+

+(declaim (inline smoke-find-method))

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

+ (m :pointer smoke-module-index)

+ (smoke :pointer)

+ (class smoke-index)

+ (method :string))

--- old-smoke/src/libsmoke/smoke.cpp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/smoke.cpp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,240 @@

+#include "cl_smoke.h"

+#include "smokebinding.h"

+

+#include <smoke.h>

+#include <QtGlobal>

+

+/** @file

+ * @brief C wrapper the Smoke bindings.

+ */

+

+using namespace cl_smoke;

+

+extern "C" {

+

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

+ *

+ * @return a pointer to a new Smoke binding.

+ */

+CL_SMOKE_EXPORT smoke_binding

+cl_smoke_construct_binding(void* destruct, void* 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_construct_binding

+ */

+CL_SMOKE_EXPORT void

+cl_smoke_destruct_binding(smoke_binding binding)

+{

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

+ delete static_cast<SmokeBinding*>(binding);

+}

+

+/** Gets a Smoke module name.

+ * @param smoke the Smoke module

+ *

+ * @return the module name

+ */

+CL_SMOKE_EXPORT const char*

+cl_smoke_get_module_name(void* smoke)

+{

+ return get_smoke(smoke)->moduleName();

+}

+

+

+/** Returns the pointer to the array @a array of @a smoke.

+ * @param smoke the Smoke module

+ * @param array the array type

+ *

+ * @return a pointer to the array

+ */

+CL_SMOKE_EXPORT void*

+cl_smoke_array(void* smoke, cl_smoke_module_array array)

+{

+ switch (array)

+ {

+ case classes:

+ return get_smoke(smoke)->classes;

+ case methods:

+ return get_smoke(smoke)->methods;

+ case method_maps:

+ return get_smoke(smoke)->methodMaps;

+ case method_names:

+ return get_smoke(smoke)->methodNames;

+ case types:

+ return get_smoke(smoke)->types;

+ case inheritance_list:

+ return get_smoke(smoke)->inheritanceList;

+ case argument_list:

+ return get_smoke(smoke)->argumentList;

+ case ambiguous_method_list:

+ return get_smoke(smoke)->ambiguousMethodList;

+ }

+ qFatal("cl_smoke_array(): Unknown smoke_array %d", array);

+}

+

+/** Returns the size of the array @a array of @a smoke.

+ * The size if inclusive the bound.

+ * @param smoke the Smoke module

+ * @param array the array type

+ *

+ * @return the size

+ */

+CL_SMOKE_EXPORT Smoke::Index

+cl_smoke_array_size(void* smoke, cl_smoke_module_array array)

+{

+ switch (array)

+ {

+ case classes:

+ return get_smoke(smoke)->numClasses;

+ case methods:

+ return get_smoke(smoke)->numMethods;

+ case method_maps:

+ return get_smoke(smoke)->numMethodMaps;

+ case method_names:

+ return get_smoke(smoke)->numMethodNames;

+ case types:

+ return get_smoke(smoke)->numTypes;

+ case inheritance_list:

+ case argument_list:

+ case ambiguous_method_list:

+ qFatal("cl_smoke_array_size(): size of %d not known.", array);

+ }

+ qFatal("cl_smoke_array_size(): Unknown smoke_array %d.", array);

+}

+

+///////////////////////////

+/// Class

+///////////////////////////

+

+/** Finds a class.

+ * @param c pointer to write the result to

+ * @param name the name of the class

+ */

+CL_SMOKE_EXPORT void

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

+{

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

+}

+

+/** Gets the class ID for a Smoke module.

+ * @param smoke the Smoke module

+ * @param name the class name

+ *

+ * @return the class ID in the supplied Smoke module

+ */

+CL_SMOKE_EXPORT Smoke::Index

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

+{

+ Smoke::ModuleIndex m = get_smoke(smoke)->idClass(name, true);

+ Q_ASSERT(m.smoke == smoke);

+

+ return m.index;

+}

+

+/** Gets a class

+ * @param smoke the smoke binding

+ * @param class_index the index of the class

+ *

+ * @return A pointer to the class into the array of class structs

+ */

+CL_SMOKE_EXPORT const struct Smoke::Class*

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

+{

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

+ return &get_smoke(smoke)->classes[class_index];

+}

+

+/** Determines werter a class is from a base class.

+ * @param smoke the Smoke module of @a class_index

+ * @param class_index the class index

+ * @param smoke_base the Smoke module of the base class @a base_index

+ * @param base_index the index of the base class

+ *

+ * @return Returns 0 when the class is not derived from the base class and nonzero value otherwise.

+ */

+CL_SMOKE_EXPORT int

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

+ Smoke::Index base_index)

+{

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

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

+

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

+ get_smoke(smoke_base), base_index);

+}

+

+//////////////////////////////

+/// Method

+//////////////////////////////

+

+/** Finds a method of a class.

+ * @param m pointer to write the result to

+ * @param smoke the smoke module

+ * @param class_index index of the class

+ * @param method_name method name

+ */

+CL_SMOKE_EXPORT void

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

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

+}

+

+///////////////////////////

+/// Type

+//////////////////////////

+

+/** Gets the index of a type.

+ * @param smoke the Smoke module

+ * @param name the types name

+ *

+ * @return the index of the type

+ */

+CL_SMOKE_EXPORT Smoke::Index

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

+{

+ return get_smoke(smoke)->idType(name);

+}

+

+/** Casts an object.

+ * @param smoke the Smoke module

+ * @param object the object

+ * @param from the class index of @a object

+ * @param to the class index to cast to

+ *

+ * @return the casted object

+ */

+CL_SMOKE_EXPORT void*

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

+{

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

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

+

+ return get_smoke(smoke)->cast(object, from, to);

+}

+

+} // extern "C"

--- old-smoke/src/libsmoke/smoke.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/smoke.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,72 @@

+(in-package #:smoke)

+

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

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

+

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

+ (use-foreign-library libclsmokeutil)

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

+ (defun cffi-bool-type ()

+ "Returns a cffi unsigned int type with the same size as a C++ bool."

+ (load-foreign-library 'libclsmokeutil)

+ (intern (format nil "UINT~A" (* 8 (smoke-sizeof-bool)))

+ (find-package :keyword)))

+

+ (defmacro defcxxbool ()

+ `(defctype cxx-bool (:boolean ,(cffi-bool-type)))))

+

+(defcxxbool)

+

+;(close-foreign-library 'libclsmokeutil)

+

+(defctype smoke-binding :pointer

+ "A Smoke binding")

+

+(defctype smoke-index :short

+ "An index")

+

+(deftype smoke-index (&optional (lower -32768) (upper 32767))

+ "Smoke index."

+ `(integer ,lower ,upper))

+

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

+ (destruct :pointer)

+ (dispatch :pointer))

+

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

+ (smoke smoke-binding))

+

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

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

+(defcstruct smoke-module-index

+ (smoke :pointer)

+ (index smoke-index))

+

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

+ (smoke :pointer))

+

+(defcenum cl-smoke-array

+ :classes

+ :methods

+ :method-maps

+ :method-names

+ :types

+ :inheritance-list

+ :argument-list

+ :ambiguous-method-list)

+

+(defcfun cl-smoke-array :pointer

+ (smoke :pointer)

+ (array cl-smoke-array))

+

+(defcfun cl-smoke-array-size smoke-index

+ (smoke :pointer)

+ (array cl-smoke-array))

--- old-smoke/src/libsmoke/smoke_util.cpp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/smoke_util.cpp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,27 @@

+#if defined _WIN32 || defined __CYGWIN__

+ #define CL_SMOKE_EXPORT __declspec(dllexport)

+#else

+ #if __GNUC__ >= 4

+ #define CL_SMOKE_EXPORT __attribute__((visibility("default")))

+ #else

+ #define CL_SMOKE_EXPORT

+ #endif

+#endif

+

+/** @file

+ * \@brief Utility functions

+ */

+

+extern "C" {

+

+/** Gets the size of the C++ bool type in bytes.

+ *

+ * @return the size of bool

+ */

+CL_SMOKE_EXPORT int

+cl_smoke_sizeof_bool()

+{

+ return sizeof(bool);

+}

+

+} // extern "C"

--- old-smoke/src/libsmoke/smokebinding.cpp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/smokebinding.cpp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,105 @@

+#include "smokebinding.h"

+

+#include <QtGlobal>

+#include <QDebug>

+

+namespace cl_smoke

+{

+

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

+ *

+ * @param binding Smoke binding of @a object

+ * @param method index of the method

+ * @param object the object for which the method is called

+ * @param args the arguments to the method

+ * @param abstract @c true when the method is abstract and @c false otherwise

+ *

+ * @return @c true when the method call was handled and @c false

+ * when the default method shall be invoked.

+ */

+

+/** Constructor.

+ * @param destruct destruct callback

+ * @param dispatch method dispatch callback

+ */

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

+ : NoDispatchBinding(destruct),

+ dispatch(dispatch)

+{

+ Q_ASSERT(dispatch);

+}

+

+

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

+bool

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

+ Smoke::Stack stack, bool abstract)

+{

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

+ Q_ASSERT( !abstract || ret );

+

+ return ret;

+}

+

+} // namespace cl_smoke

--- old-smoke/src/libsmoke/smokebinding.h 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/smokebinding.h 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,50 @@

+#ifndef SMOKEBINDING_H

+#define SMOKEBINDING_H

+

+#include <smoke.h>

+

+namespace cl_smoke

+{

+

+class NoDispatchBinding : public SmokeBinding

+{

+ public:

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

+

+ NoDispatchBinding(destructed destruct);

+

+ virtual void

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

+

+ virtual bool

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

+ Smoke::Stack stack, bool abstract);

+

+ virtual char*

+ className(Smoke::Index classId);

+

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

+};

+

+} // namespace cl_smoke

+

+#endif // SMOKEBINDING_H

--- old-smoke/src/libsmoke/stack.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/stack.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,21 @@

+(in-package #:smoke)

+

+(defcunion smoke-stack-item

+ "A variable on the Smoke stack"

+ (voidp :pointer)

+ (bool cxx-bool)

+ (char :char)

+ (uchar :unsigned-char)

+ (short :short)

+ (ushort :unsigned-short)

+ (int :int)

+ (uint :unsigned-int)

+ (long :long)

+ (ulong :unsigned-long)

+ (float :float)

+ (double :double)

+ (enum-value :long)

+ (class :pointer))

+

+(defctype smoke-stack (:pointer smoke-stack-item)

+ "A Smoke call stack.")

--- old-smoke/src/libsmoke/type.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/libsmoke/type.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -0,0 +1,20 @@

+(in-package #:smoke)

+

+(defcenum smoke-type-flags

+ "Type properties"

+ (:type-id #x0F)

+

+ (:stack #x10)

+ (:pointer #x20)

+ (:reference #x30)

+

+ (:const #x40))

+

+(defcstruct smoke-type

+ (name :string)

+ (class smoke-index)

+ (flags :unsigned-short))

+

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

+ (smoke :pointer)

+ (name :string))

--- old-smoke/src/object-map.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/object-map.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -38,8 +38,9 @@

transferred to C++.")

(eval-on-save ()

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

(loop for object being the hash-value of *object-map* do

- (warn "life object ~A" object)

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

(remove-finalizer object)

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

(clrhash *object-map*))

@@ -92,6 +93,8 @@

(class (class-of object)))

#'(lambda ()

(declare (optimize (speed 3)))

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

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

(handler-case (delete-pointer pointer class)

(error (condition)

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

@@ -110,7 +113,8 @@

(defun add-object (object)

"Adds OBJECT to the pointer -> object map. It can later be retrieved

with GET-OBJECT."

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

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

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

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

+ (cerror "Overwrite the old object."

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

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

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

--- old-smoke/src/objects/class.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/objects/class.lisp 2014-10-30 08:11:13.000000000 +0100

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

--- old-smoke/src/objects/method.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/objects/method.lisp 2014-10-30 08:11:13.000000000 +0100

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

@@ -181,6 +183,14 @@

"Returns T when METHOD is protected; NIL otherwise."

(/= 0 (get-method-flag method :protected)))

+(defun attribute-p (method)

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

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

+

+(defun property-p (method)

+ "Returns T when METHOD accesses a Q_PROPERTY."

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

+

(defmethod const-p ((method smoke-method))

"Returns T when METHOD is a const method and NIL otherwise."

(/= 0 (get-method-flag method :const)))

@@ -201,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)

--- old-smoke/src/objects/stack.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/objects/stack.lisp 2014-10-30 08:11:13.000000000 +0100

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

--- old-smoke/src/objects/type.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/objects/type.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -104,7 +104,7 @@

(defun class-p (type)

"Returns T when TYPE is a smoke class"

(and (eql (type-id type) 13)

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

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

(defun type-id (type)

"Returns the ID of TYPE."

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

--- old-smoke/src/overload-resolution.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -118,14 +118,6 @@

(push ,method ,methods))))

t)))))

-(defun all-smoke-superclasses (class)

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

- (declare (optimize (speed 3)))

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

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

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

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

-

(defun viable-functions (name argument-count class &optional const-p)

(declare (optimize (speed 3)))

(with-foreign-string (name name)

@@ -148,7 +140,7 @@

make-number-conversion make-pointer-conversion

make-boolean-conversion make-user-conversion))

(defstruct conversion

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

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

(rank -1 :type fixnum :read-only t))

(defstruct (exact-match (:include conversion (rank 0))))

@@ -203,25 +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)

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

@@ -311,8 +305,14 @@

the function CONVERSION-FUNCTION-NAME."

`(progn ,@(loop for type-name in (ensure-list type-names)

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

- #'(lambda (type)

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

+ #'(lambda (type type-p)

+ (and (if type-p

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

(define-from-lisp-translation ("void*" "const void*" "void**" "const void**")

@@ -332,7 +332,7 @@

"Test for an exact match."

(case (type-id type)

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

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

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

(1 (object.typep 'boolean))

(2 (object.typep 'standard-char))

(3 (object.typep '(c-integer :unsigned-char)))

@@ -340,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))))))

@@ -364,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))

@@ -378,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)

@@ -470,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

@@ -507,23 +528,78 @@

(condition-method condition)

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

+ (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/package.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/package.lisp 2014-10-30 08:11:13.000000000 +0100

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

--- old-smoke/src/sb-optimize.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/sb-optimize.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -90,3 +90,70 @@

(get-class method)))))))

(list ,@(sequence-form

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

+

+

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

+;;;

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

+ :hash-function (lambda (name arguments

+ class const-p)

+ (declare (string name)

+ (list arguments)

+ (sb-c::layout class)

+ (boolean const-p))

+ (logand

+ (logxor

+ (sxhash name)

+ (the fixnum

+ (reduce

+ #'logxor

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

+ arguments)))

+ (sxhash class)

+ (sxhash const-p))

+ #x1FF))

+ :hash-bits 9)

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

+ (declare (optimize (speed 3))

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

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

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

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

+ (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-layouts-cached

+ name

+ (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-c/CMakeLists.txt 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100

@@ -1,25 +0,0 @@

-find_package(Qt4 REQUIRED)

-set(QT_DONT_USE_QTGUI true)

-include(${QT_USE_FILE})

-

-include(CheckCXXCompilerFlag)

-check_cxx_compiler_flag("-fvisibility=hidden" CXX_VISIBILITY)

-if(CXX_VISIBILITY)

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

-endif(CXX_VISIBILITY)

-

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

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

-set_target_properties(smoke-c

- PROPERTIES

- SOVERSION "0.0"

- VERSION "0.0.1")

-

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

-set_target_properties(smoke-c-util

- PROPERTIES

- SOVERSION "0.0"

- VERSION "0.0.1")

-

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

- LIBRARY DESTINATION lib)

--- old-smoke/src/smoke-c/cl_smoke.h 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/cl_smoke.h 1970-01-01 01:00:00.000000000 +0100

@@ -1,62 +0,0 @@

-#ifndef CL_SMOKE_H

-#define CL_SMOKE_H

-

-#include <smoke.h>

-

-#if defined _WIN32 || defined __CYGWIN__

- #define CL_SMOKE_EXPORT __declspec(dllexport)

-#else

- #if __GNUC__ >= 4

- #define CL_SMOKE_EXPORT __attribute__((visibility("default")))

- #else

- #define CL_SMOKE_EXPORT

- #endif

-#endif

-

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

-namespace cl_smoke

-{

-class Binding;

-

-/** The arrays of the Smoke module */

-enum cl_smoke_module_array

-{

- classes,

- methods,

- method_maps,

- method_names,

- types,

- inheritance_list,

- argument_list,

- ambiguous_method_list

-};

-

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

- *

- * @return pointer to the Smoke module.

- */

-static inline

-Smoke*

-get_smoke(void* smoke)

-{

- return static_cast<Smoke*>(smoke);

-}

-} // namespace cl_smoke

-

-#endif // CL_SMOKE_H

--- old-smoke/src/smoke-c/class.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/class.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,42 +0,0 @@

-(in-package #:smoke)

-

-(defcenum smoke-class-flags

- "Class properties"

- (:constructor #x01)

- (:copy-constructor #x02)

- (:virtual-destructor #x04)

- (:undefined #x10))

-

-(defcstruct smoke-class

- "Describe a class"

- (name :string)

- (external cxx-bool)

- (parents smoke-index)

- (class-function :pointer)

- (enum-function :pointer)

- (flags :unsigned-short))

-

-(defcfun smoke-find-class :void

- (m :pointer smoke-module-index)

- (smoke :pointer)

- (name :string))

-

-(defcfun smoke-class-id smoke-index

- (smoke :pointer)

- (name :string))

-

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

- (smoke :pointer)

- (class smoke-index))

-

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

- (smoke :pointer)

- (class smoke-index)

- (smoke-base :pointer)

- (base-class smoke-index))

-

-(defcfun smoke-cast :pointer

- (smoke :pointer)

- (object :pointer)

- (from smoke-index)

- (to smoke-index))

--- old-smoke/src/smoke-c/csmokebinding.cpp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/csmokebinding.cpp 1970-01-01 01:00:00.000000000 +0100

@@ -1,87 +0,0 @@

-#include "csmokebinding.h"

-

-#include <QtGlobal>

-#include <QDebug>

-

-namespace cl_smoke

-{

-

-/** @class Binding

- * @brief The Smoke binding.

- */

-

-

-/** @typedef Binding::destructed

- * Callback when a Smoke object is destructed.

- *

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

- * @param object pointer to the object

- */

-

-

-/** @typedef Binding::dispatch_method

- * Callback when a Smoke method gets called.

- *

- * @param binding Smoke binding of @a object

- * @param method index of the method

- * @param object the object for which the method is called

- * @param args the arguments to the method

- * @param abstract @c true when the method is abstract and @c false otherwise

- *

- * @return @c true when the method call was handled and @c false

- * when the default method shall be invoked.

- */

-

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

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

- 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/smoke-c/csmokebinding.h 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/csmokebinding.h 1970-01-01 01:00:00.000000000 +0100

@@ -1,39 +0,0 @@

-#ifndef CSMOKEBINDING_H

-#define CSMOKEBINDING_H

-

-#include <smoke.h>

-

-namespace cl_smoke

-{

-

-class Binding : 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);

-

- virtual void

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

-

- virtual bool

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

- Smoke::Stack stack, bool abstract);

-

- virtual char*

- className(Smoke::Index classId);

-

- Smoke*

- get_smoke() const;

-

- private:

- const destructed destruct;

- const dispatch_method dispatch;

-};

-

-} // namespace cl_smoke

-

-#endif // CSMOKEBINDING_H

--- old-smoke/src/smoke-c/method.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/method.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,35 +0,0 @@

-(in-package #:smoke)

-

-(defcenum smoke-method-flags

- "Method flags"

- (:static #x01)

- (:const #x02)

- (:copy-constructor #x04)

- (:internal #x08)

- (:enum #x10)

- (:constructor #x20)

- (:destructor #x40)

- (:protected #x80))

-

-(defcstruct smoke-method

- "Describe a method"

- (class smoke-index)

- (name smoke-index)

- (arguments smoke-index)

- (num-args :unsigned-char)

- (flags :unsigned-char)

- (return-type smoke-index)

- (method smoke-index))

-

-(defcstruct smoke-method-map

- "Maps a munged method."

- (class-id smoke-index)

- (name smoke-index)

- (method smoke-index))

-

-(declaim (inline smoke-find-method))

-(defcfun smoke-find-method :void

- (m :pointer smoke-module-index)

- (smoke :pointer)

- (class smoke-index)

- (method :string))

--- old-smoke/src/smoke-c/smoke-c-util.cpp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/smoke-c-util.cpp 1970-01-01 01:00:00.000000000 +0100

@@ -1,27 +0,0 @@

-#if defined _WIN32 || defined __CYGWIN__

- #define CL_SMOKE_EXPORT __declspec(dllexport)

-#else

- #if __GNUC__ >= 4

- #define CL_SMOKE_EXPORT __attribute__((visibility("default")))

- #else

- #define CL_SMOKE_EXPORT

- #endif

-#endif

-

-/** @file

- * \@brief Utility functions

- */

-

-extern "C" {

-

-/** Gets the size of the C++ bool type in bytes.

- *

- * @return the size of bool

- */

-CL_SMOKE_EXPORT int

-smoke_sizeof_bool()

-{

- return sizeof(bool);

-}

-

-} // extern "C"

--- old-smoke/src/smoke-c/smoke-c.cpp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/smoke-c.cpp 1970-01-01 01:00:00.000000000 +0100

@@ -1,242 +0,0 @@

-#include "csmokebinding.h"

-#include "cl_smoke.h"

-

-#include <smoke.h>

-

-#include <QtGlobal>

-

-/** @file

- * @brief C wrapper the Smoke bindings.

- */

-

-using namespace cl_smoke;

-

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

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

- * @related cl_smoke::Binding

- * @param smoke pointer to a Smoke module instance

- * @param destruct callback for object destruction

- * @param dispatch method dispatch callback

- *

- * @return a pointer to a new Smoke binding.

- */

-CL_SMOKE_EXPORT smoke_binding

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

-{

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

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

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

-}

-

-/** Deletes the smoke binding.

- * @related cl_smoke::Binding

- */

-CL_SMOKE_EXPORT void

-smoke_destruct(smoke_binding binding)

-{

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

- delete get_smoke_binding(binding);

-}

-

-/** Gets a Smoke modules name.

- * @param smoke the Smoke module

- *

- * @return the module name

- */

-CL_SMOKE_EXPORT const char*

-smoke_get_module_name(void* smoke)

-{

- return get_smoke(smoke)->moduleName();

-}

-

-

-/** Returns the pointer to the array @a array of @a smoke.

- * @param smoke the Smoke module

- * @param array the array type

- *

- * @return a pointer to the array

- */

-CL_SMOKE_EXPORT void*

-cl_smoke_array(void* smoke, cl_smoke_module_array array)

-{

- switch (array)

- {

- case classes:

- return get_smoke(smoke)->classes;

- case methods:

- return get_smoke(smoke)->methods;

- case method_maps:

- return get_smoke(smoke)->methodMaps;

- case method_names:

- return get_smoke(smoke)->methodNames;

- case types:

- return get_smoke(smoke)->types;

- case inheritance_list:

- return get_smoke(smoke)->inheritanceList;

- case argument_list:

- return get_smoke(smoke)->argumentList;

- case ambiguous_method_list:

- return get_smoke(smoke)->ambiguousMethodList;

- }

- qFatal("cl_smoke_array(): Unknown smoke_array %d", array);

-}

-

-/** Returns the size of the array @a array of @a smoke.

- * The size if inclusive the bound.

- * @param smoke the Smoke module

- * @param array the array type

- *

- * @return the size

- */

-CL_SMOKE_EXPORT Smoke::Index

-cl_smoke_array_size(void* smoke, cl_smoke_module_array array)

-{

- switch (array)

- {

- case classes:

- return get_smoke(smoke)->numClasses;

- case methods:

- return get_smoke(smoke)->numMethods;

- case method_maps:

- return get_smoke(smoke)->numMethodMaps;

- case method_names:

- return get_smoke(smoke)->numMethodNames;

- case types:

- return get_smoke(smoke)->numTypes;

- case inheritance_list:

- case argument_list:

- case ambiguous_method_list:

- qFatal("cl_smoke_array_size(): size of %d not known.", array);

- }

- qFatal("cl_smoke_array_size(): Unknown smoke_array %d.", array);

-}

-

-///////////////////////////

-/// Class

-///////////////////////////

-

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

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

-{

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

-}

-

-/** Gets the class ID for a Smoke module.

- * @param smoke the Smoke module

- * @param name the class name

- *

- * @return the class ID in the supplied Smoke module

- */

-CL_SMOKE_EXPORT Smoke::Index

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

-{

- Smoke::ModuleIndex m = get_smoke(smoke)->idClass(name, true);

- Q_ASSERT(m.smoke == smoke);

-

- return m.index;

-}

-

-/** Gets a class

- * @param smoke the smoke binding

- * @param class_index the index of the class

- *

- * @return A pointer to the class into the array of class structs

- */

-CL_SMOKE_EXPORT const struct Smoke::Class*

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

-{

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

- return &get_smoke(smoke)->classes[class_index];

-}

-

-/** Determines werter a class is from a base class.

- * @param smoke the Smoke module of @a class_index

- * @param class_index the class index

- * @param smoke_base the Smoke module of the base class @a base_index

- * @param base_index the index of the base class

- *

- * @return Returns 0 when the class is not derived from the base class and nonzero value otherwise.

- */

-CL_SMOKE_EXPORT int

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

-

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

- get_smoke(smoke_base), base_index);

-}

-

-//////////////////////////////

-/// Method

-//////////////////////////////

-

-/** Finds a method of a class.

- * @param m pointer to write the result to

- * @param smoke the smoke binding

- * @param class_index index of the class

- * @param method_name method name

- */

-CL_SMOKE_EXPORT void

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

- if(m->index > 0)

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

-}

-

-///////////////////////////

-/// Type

-//////////////////////////

-

-/** Gets the index of a type.

- * @param smoke the Smoke module

- * @param name the types name

- *

- * @return the index of the type

- */

-CL_SMOKE_EXPORT Smoke::Index

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

-{

- return get_smoke(smoke)->idType(name);

-}

-

-/** Casts an object.

- * @param smoke the Smoke module

- * @param object the objec

- * @param from the class index of @a object

- * @param to the class index to cast to

- *

- * @return the casted object

- */

-CL_SMOKE_EXPORT void*

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

-{

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

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

-

- return get_smoke(smoke)->cast(object, from, to);

-}

-

-} // extern "C"

--- old-smoke/src/smoke-c/smoke-c.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/smoke-c.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,81 +0,0 @@

-(in-package #:smoke)

-

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

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

- (define-foreign-library libsmokeqt

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

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

- #-mudballs

- (define-foreign-library libsmoke-c

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

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

- #-mudballs

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

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

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

- (use-foreign-library libsmokeqt)

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

-

-

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

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

- (defcfun smoke-sizeof-bool :int)

- (defun cffi-bool-type ()

- "Returns a cffi unsigned int type with the same size as a C++ bool."

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

- (intern (format nil "UINT~A" (* 8 (smoke-sizeof-bool)))

- (find-package :keyword)))

-

- (defmacro defcxxbool ()

- `(defctype cxx-bool (:boolean ,(cffi-bool-type)))))

-

-(defcxxbool)

-

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

-

-(defctype smoke-binding :pointer

- "A Smoke binding")

-

-(defctype smoke-index :short

- "An index")

-

-(deftype smoke-index (&optional (lower -32768) (upper 32767))

- "Smoke index."

- `(integer ,lower ,upper))

-

-(defcfun smoke-init smoke-binding

- (smoke :pointer)

- (destruct :pointer)

- (dispatch :pointer))

-

-(defcfun smoke-destruct :void

- (smoke smoke-binding))

-

-(defcstruct smoke-module-index

- (smoke :pointer)

- (index smoke-index))

-

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

-(defcfun smoke-get-smoke :pointer

- (smoke-binding smoke-binding))

-

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

- (smoke :pointer))

-

-(defcenum cl-smoke-array

- :classes

- :methods

- :method-maps

- :method-names

- :types

- :inheritance-list

- :argument-list

- :ambiguous-method-list)

-

-(defcfun cl-smoke-array :pointer

- (smoke :pointer)

- (array cl-smoke-array))

-

-(defcfun cl-smoke-array-size smoke-index

- (smoke :pointer)

- (array cl-smoke-array))

--- old-smoke/src/smoke-c/stack.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/stack.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,21 +0,0 @@

-(in-package #:smoke)

-

-(defcunion smoke-stack-item

- "A variable on the Smoke stack"

- (voidp :pointer)

- (bool cxx-bool)

- (char :char)

- (uchar :unsigned-char)

- (short :short)

- (ushort :unsigned-short)

- (int :int)

- (uint :unsigned-int)

- (long :long)

- (ulong :unsigned-long)

- (float :float)

- (double :double)

- (enum-value :long)

- (class :pointer))

-

-(defctype smoke-stack (:pointer smoke-stack-item)

- "A Smoke call stack.")

--- old-smoke/src/smoke-c/type.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-c/type.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,20 +0,0 @@

-(in-package #:smoke)

-

-(defcenum smoke-type-flags

- "Type properties"

- (:type-id #x0F)

-

- (:stack #x10)

- (:pointer #x20)

- (:reference #x30)

-

- (:const #x40))

-

-(defcstruct smoke-type

- (name :string)

- (class smoke-index)

- (flags :unsigned-short))

-

-(defcfun smoke-find-type smoke-index

- (smoke :pointer)

- (name :string))

--- old-smoke/src/smoke-to-clos.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke-to-clos.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -4,24 +4,29 @@

"Returns an expression that defines a constant for the enum METHOD.

The second return value is the expression to export the constant."

(let ((symbol

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

- "Qt")

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

+ "Qt")

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

+ "QGlobalSpace"))

(lispify (concatenate 'string "+" (name method)

"+")

- package)

+ package)

(lispify (concatenate 'string

(name (get-class method))

".+"

(name method) "+")

- package))))

+ package))))

(values

- `(define-constant ,symbol

- (make-instance 'enum

- :value ,(enum-call method)

- :type (make-instance 'smoke-type

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

- :smoke ,smoke))

- :test #'enum=)

+ (if (= 8 (type-id (return-type method)))

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

+ ,(enum-call method))

+ `(define-constant ,symbol

+ (make-instance 'enum

+ :value ,(enum-call method)

+ :type (make-instance 'smoke-type

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

+ :smoke ,smoke))

+ :test #'enum=))

symbol)))

(defun static-method-symbol (package method)

@@ -47,11 +52,16 @@

`(defun ,name ,(if (< argument-count 0)

'(&rest args)

(make-lambda argument-count))

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

- ,method-name

- ,(if (< argument-count 0)

- 'args

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

+ (call-using-args

+ (find-class (quote ,(lispify (name class)

+ (if (string= (name class)

+ "QGlobalSpace")

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

+ package))))

+ ,method-name

+ ,(if (< argument-count 0)

+ 'args

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

name)))

(defun ensure-generic-methods (symbols-names)

@@ -77,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.

@@ -103,7 +117,10 @@

(exports))

(map-methods

#'(lambda (method)

- (when (enum-p method)

+ (when (and (enum-p method)

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

+ ;; class is external (workaround).

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

(multiple-value-bind (def export) (constant-definition package method smoke)

(push def

constants)

@@ -121,13 +138,18 @@

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

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

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

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

+ ;; existing functions e.g. qInstallMsgHandler of

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

+ ;; segfault when loading from an saved image.

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

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

(eval smoke))

(loop for id being the hash-values of function-symbols do

(let ((method (make-smoke-method

@@ -144,8 +166,11 @@

(push export exports))))

`(progn (check-recompile ,smoke)

,@functions

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

- ;; eval on startup for class map.

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

(ensure-generic-methods ',(hash-table-alist generics)))

--- old-smoke/src/smoke.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/smoke.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -1,4 +1,4 @@

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

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

;;;

;;; This program is free software: you can redistribute it and/or modify

;;; it under the terms of the GNU General Public License as published by

@@ -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,41 +73,46 @@

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

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

- (callback dispatch-method))))

- (setf (binding smoke) binding

- (smoke-module-pointer module) smoke

- (smoke-module-binding module) binding)

- (init-smoke-module module)

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

- module))

+ (use-foreign-library libclsmoke)

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

(defun register-smoke-module-var (symbol)

"Registers SYMBOL of a variable containing a pointer to a Smoke module."

(setf (gethash (pointer-address (smoke-module-pointer (eval symbol)))

@@ -145,7 +145,6 @@

(defun all-methods (name)

"Returns a list of all methods named NAME."

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

(declare (optimize (speed 3)))

(with-foreign-string (name name)

(let ((methods))

@@ -178,7 +177,8 @@

`(progn

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

(define-foreign-library ,library

- (:unix ,(format nil "~(~A~).so.2" 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)

(load-foreign-library ',library))

@@ -186,10 +186,7 @@

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

(defcvar (,variable ,variable-name :read-only t :library ,library)

:pointer)

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

- (length function-name)

- function-name)

- :library ,library)

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

:void))

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

(defparameter ,smoke-module (make-smoke-module)))

--- old-smoke/src/using-type.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/src/using-type.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -13,7 +13,7 @@

`(,function-name ,@args))

(call-using-type (function-name &rest args)

`(,function-name ,@args)))

- ,@body))

+ ,@body))

(defun typep-using-type (object-type type)

"Returns true when OBJECT-TYPE is a subtype of TYPE,

--- old-smoke/test-bundle.sh 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/test-bundle.sh 2014-10-30 08:11:13.000000000 +0100

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

exit 1

fi

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

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

--eval '(smoke:save-bundle "qt.test.run")' \

--eval '(quit)' || exit 1

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

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

--- old-smoke/test.lisp 2014-10-30 08:11:13.000000000 +0100

+++ new-smoke/test.lisp 2014-10-30 08:11:13.000000000 +0100

@@ -1,31 +1,28 @@

#|

+cmake ./ || exit 1

+make || exit 1

+echo \

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

+## Testing sbcl

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

MALLOC_CHECK_=3 sbcl --noinform --disable-debugger --noprint --load $0 --end-toplevel-options "$@" || exit 1

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

+echo \

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

+## Testing sbcl image

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

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

+echo \

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

+## Testing ccl

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

ccl --batch --quiet --load $0 || exit 3

exit 0

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

# Used for testing on darcs record.

|#

-

-(in-package :sysdef-user)

-

-(defun load-sysdef (pathname system)

- (load pathname)

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

-

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

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

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

- :name (string-downcase system-name)

- :type "mbd")

- system-name))

-

-(load-sysdef-file :smoke)

-;(mb:load :FiveAm)

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

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

-(mb:test :smoke)

+(require :asdf)

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

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

#+sbcl (sb-ext:quit)

#+ccl (ccl:quit)