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+).
Thu Aug 27 13:43:13 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Support the new smokegenerator (r1015073).
* support const correctness
* remove workarounds for the old smoke
The old smoke is no longer supported.
Thanks to Arno Rehn for making the smokegenerator work with cl-smoke.
Sun Aug 2 12:12:41 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Cleanup C++ to Lisp translation
Fri Jul 24 15:32:23 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix conversion sequence from QByteArray to const char*.
Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs
Wed Jul 8 22:41:19 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Speedup overload resolution and some other stuff for faster C++ method calling.
Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* SBCL: compile time overload resolution
diff -rN -u old-smoke/TODO new-smoke/TODO
--- old-smoke/TODO 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/TODO 1970-01-01 01:00:00.000000000 +0100
@@ -1,22 +0,0 @@
-Methods:
- * C++ overload resolution & argument promotion
- => no more writing (make-instance 'qt:byte-array :args ("foo"))
- * Test for null pointer in this and for references
- * default arguments
- * fetch name of arguments
-
-* const correctness
-
-* keyword arguments for make-instance
-
-* QApplication and KCmdLineArgs.init call exit() on e.g. "--help"
-
-Testsuite:
- * Fix segfaults when lots of qt:applictions are created & deleted
- * Test condition & restarts
-
-finalization:
- * get rid of owned-p
- * use QObject::deleteLater ?
-
-* Exceptions
diff -rN -u old-smoke/cl-smoke.smoke.asd new-smoke/cl-smoke.smoke.asd
--- old-smoke/cl-smoke.smoke.asd 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/cl-smoke.smoke.asd 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd
--- old-smoke/smoke.mbd 2014-10-30 08:13:11.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"
- ("translate" (:needs "package"))
- ("using-type" (:needs "package"))
- ("overload-resolution" (:needs "package" "smoke" "using-type"))
- ("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"))
- ("method" (:needs "clos" "overload-resolution"))
- (:objects module
- (:needs "smoke-c" "utils")
- (:serial t)
- (:components "object" "enum" "type" "method" "class"
- "instance" "stack"))
- (:smoke-c module
- (:needs "package" "translate")
- (: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))
diff -rN -u old-smoke/src/CMakeLists.txt new-smoke/src/CMakeLists.txt
--- old-smoke/src/CMakeLists.txt 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/CMakeLists.txt 2014-10-30 08:13:11.000000000 +0100
@@ -1 +1 @@
-add_subdirectory(smoke-c)
+add_subdirectory(libsmoke)
diff -rN -u old-smoke/src/bindings.lisp new-smoke/src/bindings.lisp
--- old-smoke/src/bindings.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/bindings.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -1,34 +1,12 @@
(in-package :smoke)
-(defvar *bindings* (make-hash-table))
-
-;; 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)
@@ -40,7 +18,18 @@
(argument-list (null-pointer) :type foreign-pointer)
(ambiguous-method-list (null-pointer) :type foreign-pointer))
-(defvar *smoke-modules* (make-hash-table))
+(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)
+ (print-unreadable-object (smoke-module stream :type t :identity t)
+ (princ (smoke-get-module-name (smoke-module-pointer smoke-module))
+ stream))))
(defun init-smoke-module (module)
(let ((smoke (smoke-module-pointer module)))
diff -rN -u old-smoke/src/class-map.lisp new-smoke/src/class-map.lisp
--- old-smoke/src/class-map.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/class-map.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -5,36 +5,32 @@
"Maps a Smoke module pointer - id pair to a class.")
;; FIXME disallow adding a class when threads are running or add a lock.
-
(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)
- (setf (gethash (pointer-address (smoke-module-pointer smoke)) *smoke-id-class-map*)
+ (setf (gethash (pointer-address (smoke-module-pointer smoke))
+ *smoke-id-class-map*)
new-value))
(defun add-id-class-map (smoke)
- (setf (id-class-map smoke)
- (make-hash-table)))
+ (setf (id-class-map smoke) (make-hash-table)))
(defun add-id (smoke-class class)
"Associates the CLOS class CLASS with SMOKE-CLASS."
- (setf (gethash (id smoke-class)
- (id-class-map (smoke smoke-class)))
+ (setf (gethash (id smoke-class) (id-class-map (smoke smoke-class)))
class))
-(defun find-smoke-class (class)
+(defun find-smoke-class (class &optional (error-p t))
"Returns the CLOS class for smoke-class CLASS."
- (let* ((class (real-class class))
- (ret (gethash (id class)
- (id-class-map (smoke class)))))
- (assert (not (null ret))
- ()
- "The class ~A was not found." (name class))
+ (let* ((class (handler-case (real-class class)
+ (undefined-class (e) (when error-p (error e)))))
+ (ret (when class (gethash (id class) (id-class-map (smoke class))))))
+ (when error-p
+ (assert (not (null ret))
+ ()
+ "The class ~A was not found." (name class)))
ret))
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/clos.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -9,7 +9,6 @@
(values (intern (cxx-to-lisp name)))
(values (intern (cxx-to-lisp name) package))))
-
(defmacro define-string-transform (name documentation &body states)
"Defines a function to transform a string."
(let ((output (gensym))
@@ -19,8 +18,8 @@
,documentation
(declare (simple-string input)
(optimize (speed 3)))
- ;; At least on sbcl 1.0.25.debian CONCATENATE is faster
- ;; than VECTOR-PUSH-EXTEND
+ ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than
+ ;; VECTOR-PUSH-EXTEND.
(let ((,output "")
(,index 0)
(,length (length input))
@@ -109,6 +108,8 @@
(defmethod print-object ((object smoke-standard-object) stream)
(if (slot-boundp object 'pointer)
(print-unreadable-object (object stream :type t)
+ (when (const-p object)
+ (princ "CONST " stream))
(princ (pointer object) stream))
(call-next-method)))
@@ -117,105 +118,117 @@
(:documentation "A Smoke C++ class"))
(defclass cxx:class (smoke-standard-class)
- ((pointer :type smoke-standard-class))
+ ()
(:documentation "Metaclass to extend Smoke Objects."))
-(defmethod pointer ((class cxx:class))
- (pointer (slot-value class 'pointer)))
+(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)
+
+(defmethod closer-mop:validate-superclass ((class cxx:class)
+ (superclass smoke-standard-class))
+ t)
+
+;; Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default
+;; STANDARD-OBJECT.
+(defun init-smoke-standard-class (class next-method
+ &rest args &key direct-superclasses
+ &allow-other-keys)
+ (apply next-method class
+ :direct-superclasses (or direct-superclasses
+ (list (find-class 'smoke-standard-object)))
+ args))
+
+(defmethod initialize-instance :around ((class smoke-standard-class) &rest args)
+ (apply #'init-smoke-standard-class class #'call-next-method args))
-(defmethod closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))
- T)
+(defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args)
+ (apply #'init-smoke-standard-class class #'call-next-method args))
-(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))
- T)
-(defmethod reinitialize-instance :around
- ((class smoke-standard-class)
- &rest args &key direct-superclasses &allow-other-keys)
- (apply
- #'call-next-method class
- :direct-superclasses (or direct-superclasses
- (list (find-class
- 'smoke-standard-object))) args))
-
-(defmethod initialize-instance :around
- ((class smoke-standard-class)
- &rest args &key direct-superclasses &allow-other-keys)
- "Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default STANDARD-OBJECT."
- (apply
- #'call-next-method class
- :direct-superclasses (or direct-superclasses
- (list (find-class 'smoke-standard-object)))
- args))
-
-(defmethod reinitialize-instance :around
- ((class cxx:class)
- &rest args &key direct-superclasses &allow-other-keys)
+(defun init-cxx-class (class next-method &rest args &key direct-superclasses
+ direct-default-initargs &allow-other-keys)
(assert (not (null direct-superclasses))
(direct-superclasses)
"No superclass supplied for class ~A" class)
- (let ((superclass (first direct-superclasses)))
- (assert (subtypep (class-of superclass) (find-class 'smoke-standard-class))
- ((first direct-superclasses))
- "The first superclass must be an subclass of an smoke class.")
- (apply
- #'call-next-method class
- :pointer superclass
- :smoke (smoke superclass)
- :direct-superclasses direct-superclasses
- args)))
-
-(defmethod initialize-instance :around
- ((class cxx:class)
- &rest args &key direct-superclasses &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))
+ (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
- #'call-next-method class
- :pointer superclass
+ next-method class
+ :id (id superclass)
:smoke (smoke superclass)
:direct-superclasses direct-superclasses
+ :direct-default-initargs direct-default-initargs
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))))
+(defmethod reinitialize-instance :around ((class cxx:class) &rest args)
+ (apply #'init-cxx-class class #'call-next-method args))
+
+(defmethod initialize-instance :around ((class cxx:class) &rest args)
+ (apply #'init-cxx-class class #'call-next-method args))
+(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 (external-p class)
- (add-id class
- (closer-mop:ensure-class (lispify (name class))
- :direct-superclasses
- (mapcar #'smoke-class-symbol
- (smoke-class-direct-superclasses class))
- :pointer
- (pointer class)
- ;(mem-aref (smoke-array-pointer
- ; (smoke-module-classes
- ; (smoke class)))
- ; 'smoke-class
- ; (id class))
- :smoke (smoke class)
- :metaclass 'smoke-standard-class))
- (export (lispify (name class)))))
+ (with-simple-restart (skip "Skip generating class ~A" (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)
@@ -254,10 +267,18 @@
(list ,@(rest lambda-list))))))))
(defcallback destructed :void
- ((object-pointer :pointer))
+ ((object-pointer :pointer))
(declare (optimize (speed 3)))
(let ((object (get-object object-pointer)))
+ ;; The destructed callback can be the result of deleting the object
+ ;; 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)))))
@@ -265,6 +286,7 @@
(declaim (inline argument-to-lisp))
(defun argument-to-lisp (stack-item type)
;; FIXME do not take ownership of stack allocated objects.
+ ;; It looks like there is no stack allocation in Qt virtual method signatures.
(type-to-lisp stack-item type))
(defun stack-to-args (stack arg &optional (args nil))
@@ -275,136 +297,149 @@
(stack-to-args (inc-pointer stack
(foreign-type-size 'smoke-stack-item))
(next arg)
- (push (argument-to-lisp (mem-ref stack
- 'smoke-stack-item)
- arg)
+ (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item)
+ 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 (top 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)
- (transfer-ownership-to value object)))))))
+ (setf (call-stack-top stack) (call-stack-pointer stack))
+ (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 virtual function calls.
(defcallback dispatch-method :boolean
- ((binding :pointer)
- (method smoke-index)
+ ((method smoke-index)
(object-ptr :pointer)
(stack smoke-stack)
(abstract :boolean))
(declare (optimize (speed 3)))
(let ((object (get-object object-ptr)))
- ;; FIXME:
- ;;(assert object
- ;; (object)
- ;; "No object for ~A to call ~A." object-ptr method)
- (if (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.
- (let* ((method (make-smoke-method
- :smoke (gethash (pointer-address (smoke-get-smoke binding))
- *smoke-modules*)
- :id method)))
- (loop
- (restart-case
- (return-from dispatch-method
- (let ((gf (get-gf-for-method method)))
- (declare (function gf))
- (if (null (gf-methods gf))
- (progn
- (when abstract
- (error "Abstract method ~A called."
- (method-declaration method)))
- nil)
- (if object
- (progn
- (put-returnvalue stack
- (apply gf object
- (stack-to-args
- (inc-pointer stack
- (foreign-type-size
- 'smoke-stack-item))
- (get-first-argument method)))
- (return-type method)
- object)
- t)
- nil))))
- ;; Restarts to prevent stack unwinding across the C++ stack.
- (call-default ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Call default implementation ~A instead."
- method))
- :test (lambda (condition)
- (declare (ignore condition))
- (not abstract))
- (return-from dispatch-method nil))
- (use-returnvalue (return-value)
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Supply a return value for ~A."
- (method-declaration method)))
- :test (lambda (condition)
- (declare (ignore condition))
- (not (void-p (return-type method))))
- :interactive (lambda ()
- (format *query-io* "~&Enter a new return value: ")
- (multiple-value-list (eval (read *query-io*))))
- (put-returnvalue stack return-value
- (return-type method)
- (get-object object-ptr))
- (return-from dispatch-method t))
- (return ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Return void for ~A."
- (method-declaration method)))
- :test (lambda (condition)
- (declare (ignore condition))
- (void-p (return-type method)))
- (return-from dispatch-method (values)))
- (retry ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Try again calling ~A."
- (method-declaration method))))))
- nil))))
+ ;; 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.
+ (unless (null object)
+ (let* ((method (make-smoke-method
+ :smoke (smoke (class-of object))
+ :id method)))
+ (loop
+ (restart-case
+ (return-from dispatch-method
+ (let ((gf (get-gf-for-method method)))
+ (declare (function gf))
+ (if (null (gf-methods gf))
+ (progn
+ (when abstract
+ (error "Abstract method ~A of ~A called."
+ (method-declaration method) object))
+ nil)
+ (if object
+ (progn
+ (put-returnvalue
+ stack
+ (apply gf object
+ (stack-to-args
+ (inc-pointer stack (foreign-type-size
+ 'smoke-stack-item))
+ (get-first-argument method)))
+ (return-type method) object)
+ t)
+ nil))))
+ ;; Restarts to prevent stack unwinding across the C++ stack.
+ (call-default ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream
+ "Call default implementation ~A instead."
+ method))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (not abstract))
+ (return-from dispatch-method nil))
+ (use-returnvalue (return-value)
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Supply a return value for ~A."
+ (method-declaration method)))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (not (void-p (return-type method))))
+ :interactive (lambda ()
+ (format *query-io* "~&Enter a new return value: ")
+ (multiple-value-list (eval (read *query-io*))))
+ (put-returnvalue stack return-value
+ (return-type method)
+ (get-object object-ptr))
+ (return-from dispatch-method t))
+ (return ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Return void for ~A."
+ (method-declaration method)))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (void-p (return-type method)))
+ (return-from dispatch-method (values)))
+ (retry ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Try again calling ~A."
+ (method-declaration method))))))
+ nil))))
;;FIXME use CHANGE-CLASS instead?
-(defun cast (object class)
- "Returns a pointer of type CLASS to the C++ object of OBJECT."
- (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 (real-class class))))
- (id (class-of object)) (id class)))
-
+(defgeneric cast (object class)
+ (declare (optimize (speed 3)))
+ (: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))
@@ -415,28 +450,37 @@
(id (class-of object)) (id (real-class class))))
-(defmethod convert-to-class (smoke-class (object smoke-standard-object))
- (cast object smoke-class))
-
-(defun call-constructor (object arguments)
- (if (null arguments)
- (let ((method (find-smoke-method (class-of object)
- (name (class-of object)))))
- (pointer-call method (null-pointer)))
- (multiple-value-bind (method sequence)
- (find-best-viable-function (name (class-of object))
- arguments
- (class-of object))
- (when (null method)
- (error "No constructor ~A for ~S"
- object arguments))
- (pointer-call method (null-pointer)
- (mapcar #'(lambda (conversion argument)
- (funcall conversion argument))
- sequence arguments)))))
+;; The constructor name is the name of the class minus any namespace parts.
+(defun constructor-name (class)
+ (declare (optimize (speed 3)))
+ (let* ((name (the simple-string (name class)))
+ (name-start (search "::" name :from-end t)))
+ (if name-start
+ (subseq name (+ name-start 2))
+ name)))
+
+(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 &allow-other-keys)
+ &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."
(declare (optimize (speed 3)))
@@ -446,16 +490,52 @@
"Pointer ~A bound and constructor argument :ARGS ~S supplied."
(slot-value object 'pointer) args)
(unless (slot-boundp object 'pointer)
- (setf (slot-value object 'pointer) (call-constructor object args))
+ (if arg0p
+ (setf (slot-value object 'pointer)
+ (call-constructor (class-of object)
+ (cond
+ (arg3p (list arg0 arg1 arg2 arg3))
+ (arg2p (list arg0 arg1 arg2))
+ (arg1p (list arg0 arg1))
+ (t (list arg0)))))
+ (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)
(optimize (speed 3)))
- (let ((ret (make-instance class :pointer pointer)))
+ (let ((ret (make-instance class :pointer pointer
+ :const-p (const-p type))))
(when (stack-p type)
(take-ownership ret)
(add-object ret))
@@ -465,8 +545,8 @@
(declare (type smoke-standard-object object)
(optimize (speed 3)))
(when (member object (owned-objects new-owner))
- (cerror "ignore" "~A has already been called for ~A."
- #'keep-wrapper object))
+ (cerror "Ignore" "~A has already been added to ~A."
+ object new-owner))
(push object (owned-objects new-owner)))
(declaim (inline remove-wrapper-object))
diff -rN -u old-smoke/src/cxx-method.lisp new-smoke/src/cxx-method.lisp
--- old-smoke/src/cxx-method.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/cxx-method.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -1,13 +1,11 @@
(in-package :smoke)
(defclass cxx-generic-function (standard-generic-function)
- ((gf-methods :initform nil
+ ((gf-methods :initform nil :type list
:accessor gf-methods
- :type list
- :documentation "Generic functions for different argument counts."))
+ :documentation "gf for different argument counts."))
(:metaclass closer-mop:funcallable-standard-class)
- (:documentation
- "A generic function that can be overloaded by argument count."))
+ (:documentation "gf that can be overloaded by argument count."))
(defclass cxx-method-generic-function (standard-generic-function)
((generic-function :accessor cxx-generic-function
@@ -36,8 +34,7 @@
((integer 0) argument-count)
(values (or cxx-method-generic-function null)))
(find-if #'(lambda (gf)
- (= argument-count
- (argument-count gf)))
+ (= argument-count (argument-count gf)))
(gf-methods cxx-generic-function)))
(defun cxx-method-generic-function-name (cxx-generic-function argument-count)
@@ -80,8 +77,9 @@
(defun push-method (method cxx-generic-function)
"Adds METHOD to a cxx-method-generic-function of CXX-GENERIC-FUNCTION."
(declare (optimize (speed 3)))
- (let ((generic-function (ensure-gf-by-argument-count cxx-generic-function
- (method-argument-count method))))
+ (let ((generic-function (ensure-gf-by-argument-count
+ cxx-generic-function
+ (method-argument-count method))))
(add-method generic-function method)))
(defun unpush-method (method)
diff -rN -u old-smoke/src/libsmoke/CMakeLists.txt new-smoke/src/libsmoke/CMakeLists.txt
--- old-smoke/src/libsmoke/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/CMakeLists.txt 2014-10-30 08:13:11.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)
diff -rN -u old-smoke/src/libsmoke/cl_smoke.h new-smoke/src/libsmoke/cl_smoke.h
--- 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:13:11.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
diff -rN -u old-smoke/src/libsmoke/class.lisp new-smoke/src/libsmoke/class.lisp
--- old-smoke/src/libsmoke/class.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/class.lisp 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/src/libsmoke/method.lisp new-smoke/src/libsmoke/method.lisp
--- old-smoke/src/libsmoke/method.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/method.lisp 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/src/libsmoke/smoke.cpp new-smoke/src/libsmoke/smoke.cpp
--- old-smoke/src/libsmoke/smoke.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/smoke.cpp 2014-10-30 08:13:11.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"
diff -rN -u old-smoke/src/libsmoke/smoke.lisp new-smoke/src/libsmoke/smoke.lisp
--- old-smoke/src/libsmoke/smoke.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/smoke.lisp 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/src/libsmoke/smoke_util.cpp new-smoke/src/libsmoke/smoke_util.cpp
--- 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:13:11.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"
diff -rN -u old-smoke/src/libsmoke/smokebinding.cpp new-smoke/src/libsmoke/smokebinding.cpp
--- old-smoke/src/libsmoke/smokebinding.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/smokebinding.cpp 2014-10-30 08:13:11.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
diff -rN -u old-smoke/src/libsmoke/smokebinding.h new-smoke/src/libsmoke/smokebinding.h
--- old-smoke/src/libsmoke/smokebinding.h 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/smokebinding.h 2014-10-30 08:13:11.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
diff -rN -u old-smoke/src/libsmoke/stack.lisp new-smoke/src/libsmoke/stack.lisp
--- old-smoke/src/libsmoke/stack.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/stack.lisp 2014-10-30 08:13:11.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.")
diff -rN -u old-smoke/src/libsmoke/type.lisp new-smoke/src/libsmoke/type.lisp
--- old-smoke/src/libsmoke/type.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/type.lisp 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp
--- old-smoke/src/method.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/method.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,158 +0,0 @@
-(in-package :smoke)
-
-(defun constant-definition (package method smoke)
- "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")
- (lispify (concatenate 'string "+" (name method)
- "+")
- package)
- (lispify (concatenate 'string
- (name (get-class method))
- ".+"
- (name method) "+")
- 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=)
- symbol)))
-
-(defun static-method-symbol (package method)
- "Returns the lisp symbol for the static method METHOD."
- (let ((class (get-class method)))
- (lispify (concatenate 'string
- (if (string= (name class)
- "QGlobalSpace")
- nil
- (concatenate 'string
- (name class)
- "."))
- (name method))
- package)))
-
-(defun static-method-definition (package method &optional (argument-count -1))
- "Returns an expression to define a function for the static METHOD.
-The second return value is the expression to export the function."
- (let* ((class (get-class method))
- (method-name (name method))
- (name (static-method-symbol package method)))
- (values
- `(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)))))
- name)))
-
-(defun ensure-generic-methods (symbols-names)
- "Ensures the generic functions for SYMBOLS-NAMES."
- (declare (list symbols-names)
- (optimize (speed 3)))
- (dolist (symbol-name symbols-names)
- (ensure-generic-function (first symbol-name)
- :cxx-name (rest symbol-name)
- :generic-function-class 'smoke-gf
- :lambda-list '(object &rest args))
- (export (first symbol-name) :cxx)))
-
-
-(defun setf-method-definition (method)
- `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
- (,(lispify (name method) :cxx) object new-value)
- new-value))
-
-(defmacro sizes= ((smoke)&rest arrays)
- `(and ,@(loop for array in arrays collect
- `(= (smoke-array-length (,array ,smoke))
- ,(smoke-array-length (funcall (fdefinition array)
- (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))))))
-
-(defmacro define-classes-and-gfs (package smoke)
- "Process the C++ methods of the Smoke module SMOKE.
-Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods
-and a function do define the generic methods a load-time."
-;;; symbol - id pairs are stored in the hash-tables to prevent the
-;;; multiple definition of a function with the same name.
- (let ((generics (make-hash-table))
- (constants)
- (functions)
- (function-symbols (make-hash-table))
- (setf-function-symbols (make-hash-table))
- (exports))
- (map-methods
- #'(lambda (method)
- (when (and (enum-p method)
- ;; FIXME workaround for
- ;; http://lists.kde.org/?l=kde-bindings&m=123464781307375
- (not (string= (name (get-class method))
- "KGlobalSettings")))
- (multiple-value-bind (def export) (constant-definition package method smoke)
- (push def
- constants)
- (push export exports)))
- (when (and (not (destructor-p method))
- (not (constructor-p method))
- (not (enum-p method))
- (not (eql nil (name method)))
- (string/= (name method) "tr")) ;; we have a custom qt:tr function
- (let ((name (name method)))
- (when (and (starts-with-subseq "set" name)
- (> (length name) 3)
- (upper-case-p (char name 3))
- (= 1 (get-arguments-length method)))
- (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))
- (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)))))))
- (eval smoke))
- (loop for id being the hash-values of function-symbols do
- (let ((method (make-smoke-method
- :smoke (eval smoke)
- :id (abs id))))
- (multiple-value-bind (definition export)
- (static-method-definition
- package
- method
- (if (< 0 id)
- (get-arguments-length method)
- -1))
- (push definition functions)
- (push export exports))))
- `(progn (check-recompile ,smoke)
- ,@functions
- (eval-startup (:execute)
- (make-smoke-classes ,package ,smoke)
- (ensure-generic-methods ',(hash-table-alist generics)))
- ,@constants
- (eval-when (:load-toplevel :execute)
- (export (quote ,exports) ,package)))))
-
diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp
--- old-smoke/src/object-map.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/object-map.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -6,7 +6,6 @@
(make-weak-hash-table :weakness weakness :synchronized t)
(make-weak-hash-table :synchronized t)))
-
#+openmcl
(let ((ccl::*shared-hash-table-default* t))
(defun make-synchronized-hash-table (&key weakness)
@@ -35,12 +34,13 @@
(defvar *object-map* (make-synchronized-hash-table :weakness :value)
"Contains all objects constructed by Smoke, that are not yet destructed;
-except object with a non virtual destructor which had their ownership transferred
-to C++.")
+except object with a non virtual destructor which had their ownership
+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*))
@@ -59,15 +59,9 @@
"Returns T when there is an object for POINTER in the map and NIL otherwise."
(nth-value 1 (gethash (pointer-address pointer) *object-map*)))
-(defun remove-if-exists (pointer)
- (remhash (pointer-address pointer) *object-map*))
-
(defun remove-object (pointer)
- (declare (optimize (speed 3)))
- (assert (has-pointer-p pointer)
- (pointer)
- "No object to remove for pointer ~A." pointer)
- (remhash (pointer-address pointer) *object-map*))
+ (unless (remhash (pointer-address pointer) *object-map*)
+ (cerror "ignore" "No object to remove for pointer ~A." pointer)))
(defun report-finalize-error (condition function class pointer)
"Report the error CONDITION it the finalizer FUNCTION for the
@@ -99,15 +93,28 @@
(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))))))
-
+
+(defun debug-finalize ()
+ (eval '(defmethod make-finalize :around (object)
+ (let ((pointer (pointer object))
+ (class (class-of object))
+ (next (call-next-method)))
+ #'(lambda ()
+ (format *debug-io* "cl-smoke: finalizing: ~A..."
+ (make-instance class :pointer pointer))
+ (funcall next)
+ (format *debug-io* "done~%"))))))
+
(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))
diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp
--- old-smoke/src/objects/class.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/objects/class.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -1,48 +1,43 @@
(in-package #:smoke)
(defclass smoke-class ()
- ;; FXIME maybe change back to id
- ((pointer ;:type foreign-pointer
- :initarg :pointer
- :reader pointer)
+ ((id :initform 0 :type smoke-index
+ :reader id :initarg :id)
(smoke :type smoke-module
- :initarg :smoke
- :reader smoke))
- (:documentation "A class"))
+ :reader smoke :initarg :smoke)))
(defun make-smoke-class-from-id (smoke id)
- (make-instance 'smoke-class
- :pointer (mem-aref (smoke-array-pointer (smoke-module-classes
- smoke))
- 'smoke-class
- id)
- :smoke smoke))
+ (make-instance 'smoke-class :id id :smoke smoke))
-(defmethod id ((class smoke-class))
- (declare (values (smoke-index 0))
- (optimize (speed 3)))
- (values
- (floor
- (the (integer 0)
- (- (pointer-address (pointer class))
- (pointer-address (smoke-array-pointer (smoke-module-classes
- (smoke class))))))
- #.(cffi:foreign-type-size 'smoke-class))))
+(declaim (inline smoke-class-pointer))
+(defun smoke-class-pointer (class)
+ (mem-aref (the foreign-pointer
+ (smoke-array-pointer (smoke-module-classes (smoke class))))
+ 'smoke-class
+ (the smoke-index (id class))))
(declaim (inline class-slot-value))
(defun class-slot-value (class slot-name)
- (foreign-slot-value (pointer class)
+ (foreign-slot-value (smoke-class-pointer class)
'smoke-class slot-name))
(define-compiler-macro class-slot-value (&whole form class slot-name)
(if (constantp slot-name)
- `(foreign-slot-value (pointer ,class)
+ `(foreign-slot-value (smoke-class-pointer ,class)
'smoke-class ,slot-name)
form))
(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)
@@ -50,15 +45,14 @@
(let ((class (make-instance 'smoke-class
:smoke smoke)))
(loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do
- (setf (slot-value class 'pointer)
- (mem-aref (smoke-array-pointer (smoke-module-classes smoke))
- 'smoke-class
- id))
+ (setf (slot-value class 'id)
+ id)
(funcall function class))))
(defun external-p (class)
"Returns T when CLASS is external in its module; NIL otherwise."
- (declare (optimize (speed 3)))
+ (declare (type smoke-class class)
+ (optimize (speed 3)))
(class-slot-value class 'external))
(defun get-class-flag (class flag)
@@ -70,45 +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"))
-;smoke-find-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
- :pointer (smoke-get-class
- (foreign-slot-value c 'smoke-module-index 'smoke)
- (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)
- (make-smoke-class (smoke class) (name class))
+ (make-smoke-class (name class))
class))
(defun class-id (module class)
@@ -117,16 +121,17 @@
(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)) (id class)
- (smoke-module-pointer (smoke base-class)) (id base-class)))
+ (smoke-is-derived-from (smoke-module-pointer (smoke class))
+ (id class)
+ (smoke-module-pointer (smoke base-class))
+ (id base-class)))
(defun smoke-class-direct-superclasses (class)
@@ -137,13 +142,12 @@
(smoke class))
'smoke-index
index)))
- (assert (<= class-index
- (smoke-array-length
- (smoke-module-classes (smoke class)))))
+ (assert (<= class-index (smoke-array-length
+ (smoke-module-classes (smoke class)))))
(if (= 0 class-index)
classes
- (smoke-add-superclass class (append classes
- (list
- (make-smoke-class-from-id (smoke class)
- class-index)))
- (1+ index)))))
+ (smoke-add-superclass
+ class
+ (append classes
+ (list (make-smoke-class-from-id (smoke class) class-index)))
+ (1+ index)))))
diff -rN -u old-smoke/src/objects/enum.lisp new-smoke/src/objects/enum.lisp
--- old-smoke/src/objects/enum.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/objects/enum.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -3,7 +3,6 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :smoke :cxx-support))
-;;;
;;; One could map enum-values to lisp symbols, store the type in the plist
;;; an use those as enums, but C++ enums may have several symbols for
;;; the same value and thus lisp symbols can not be used.
@@ -31,7 +30,7 @@
(defun check-enum-type (enum enum-type)
(assert (smoke-type= (enum-type enum)
- enum-type)
+ enum-type)
(enum enum-type)
"The enums ~A is not of type ~A." enum (name enum-type)))
@@ -39,23 +38,32 @@
"Returns true when ENUM1 and ENUM2 are equal and false otherwise."
(declare (enum enum1 enum2))
(assert (smoke-type= (enum-type enum1)
- (enum-type enum2))
+ (enum-type enum2))
(enum1 enum2)
"The enums ~A and ~A have a different type." enum1 enum2)
(= (value enum1) (value enum2)))
(defmacro enum-xcase (case keyform &body cases)
- (let ((type (enum-type (eval (first (first cases))))))
+ (flet ((first-key (keys)
+ (if (listp keys)
+ (first keys)
+ keys)))
+ (let ((type (enum-type (eval (first-key (first (first cases)))))))
(loop for case in cases do
- (check-enum-type (eval (first case))
+ (check-enum-type (eval (first-key (first case)))
type)))
`(progn
- ; (check-enum-type (enum-type ,keyform)
- ; (enum-type ,(first (first cases))))
+ ;; (check-enum-type (enum-type ,keyform)
+ ;; (enum-type ,(first (first cases))))
(,case (value ,keyform)
,@(loop for case in cases
- collect `(,(value (eval (first case)))
- ,@(rest case))))))
+ collect `(,(if (listp (first case))
+ (mapcar #'(lambda (c)
+ (print c)
+ (value (eval c)))
+ (first case))
+ (value (eval (first case))))
+ ,@(rest case)))))))
(defmacro enum-case (keyform &body cases)
`(enum-xcase case ,keyform ,@cases))
@@ -67,8 +75,8 @@
"Keyform returns a number; cases are enums."
`(case ,keyform
,@(loop for case in cases
- collect `(,(value (eval (first case)))
- ,@(rest case)))))
+ collect `(,(value (eval (first case)))
+ ,@(rest case)))))
(defun enum-logand (&rest enums)
(apply #'logand (mapcar #'value enums)))
diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp
--- old-smoke/src/objects/method.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/objects/method.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -14,9 +14,11 @@
(smoke-method-id method)))
(defmethod print-object ((smoke-method smoke-method) stream)
- (if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method)))
+ (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))))
@@ -47,6 +49,13 @@
(gethash (pointer-address smoke) *smoke-modules*))
:id (foreign-slot-value m 'smoke-module-index 'index)))))
+(declaim (inline smoke-method-name))
+(defun smoke-method-name (method)
+ (mem-aref (smoke-array-pointer (smoke-module-method-names
+ (smoke-method-smoke method)))
+ :pointer
+ (the (smoke-index 0) (method-slot-value method 'name))))
+
;smoke-find-method
(defun make-smoke-method-from-name (class name)
"Returns the method NAME of CLASS.
@@ -128,11 +137,12 @@
"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."
+ (declare (optimize (speed 3)))
(make-instance 'smoke-type
:id (method-slot-value method 'return-type)
:smoke (smoke-method-smoke method)))
@@ -173,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)))
@@ -193,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)
@@ -206,7 +228,7 @@
(declare (optimize (speed 3)))
(mem-aref (smoke-module-argument-list (smoke argument))
'smoke-index
- (call-next-method)))
+ (the smoke-index (call-next-method))))
(defun last-p (argument)
"Returns T when ARGUMENT is the last argument and NIL otherwise."
@@ -244,7 +266,6 @@
:id (+ (method-slot-value method 'arguments) index)
:smoke (smoke-method-smoke method)))
-
(defun build-argument-list (list argument)
(if (end-p argument)
list
diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp
--- old-smoke/src/objects/stack.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/objects/stack.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -1,48 +1,48 @@
(in-package #:smoke)
-(defclass call-stack ()
- ((pointer :reader pointer :initarg :pointer
- :initform (null-pointer)
- :type foreign-pointer
- :documentation "Pointer to the Smoke stack")
- (top :accessor top :initarg :top
- :initform (null-pointer)
- :type foreign-pointer
- :documentation "Pointer to push the next argument to."))
- (:documentation "Contains the argument passed to a Smoke method."))
+(declaim (inline %make-call-stack))
+(defstruct (call-stack (:constructor %make-call-stack))
+ (pointer (null-pointer) :type foreign-pointer)
+ (top (null-pointer) :type foreign-pointer))
(defgeneric size (object))
(defmethod size ((stack call-stack))
"Returns the size (number of arguments) of STACK."
- (/
- (- (pointer-address (top stack))
- (pointer-address (pointer stack)))
- (foreign-type-size 'smoke-stack-item)))
+ (/ (- (pointer-address (call-stack-top stack))
+ (pointer-address (call-stack-pointer stack)))
+ (foreign-type-size 'smoke-stack-item)))
(defun make-call-stack (smoke-stack)
- (declare (optimize (speed 3)))
- (make-instance 'call-stack
- :pointer smoke-stack
- :top (inc-pointer smoke-stack (foreign-type-size 'smoke-stack-item))))
+ (declare (type foreign-pointer smoke-stack)
+ (optimize (speed 3)))
+ (%make-call-stack
+ :pointer smoke-stack
+ :top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item))))
(defun push-stack (stack value type)
- (setf (foreign-slot-value (top stack)
- 'smoke-stack-item type) value)
- (incf-pointer (top stack) #.(foreign-type-size 'smoke-stack-item)))
+ (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)
+ value)
+ (incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))
(define-compiler-macro push-stack (&whole form stack value type)
(if (constantp type)
`(progn
- (setf (foreign-slot-value (top ,stack)
- 'smoke-stack-item ,type) ,value)
- (incf-pointer (top ,stack) ,(foreign-type-size 'smoke-stack-item)))
+ (setf (foreign-slot-value (call-stack-top ,stack)
+ 'smoke-stack-item ,type)
+ ,value)
+ (incf-pointer (call-stack-top ,stack)
+ ,(foreign-type-size 'smoke-stack-item)))
form))
-
(defclass smoke-standard-object ()
((pointer :reader pointer
+ :type foreign-pointer
:initarg :pointer
:documentation "Pointer to the C++ object.")
+ (const-p :reader const-p
+ :initarg :const-p
+ :initform nil
+ :documentation "Returns true when the object is const and nil otherwise.")
#+clisp (finalizer :type list :initform (list nil))
;; We can not have a global table of objects owned by C++,
;; since then they would be always reachable from Lisp and thus
@@ -99,26 +99,22 @@
,types)
,@body))))
+(defvar *to-lisp-translations* (make-hash-table :test 'equal))
+
(defun enum-to-lisp (stack-item type)
"Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."
(declare (optimize (speed 3)))
(ecase (type-id type)
- (0 (let ((cffi-type (get-type (name type))))
- (if (null cffi-type)
- (progn
- ;; FIXME warn but not on void**
- ;;(warn "Unknown translation from ~A to lisp." (name type))
- (foreign-slot-value stack-item 'smoke-stack-item 'voidp))
- (let* ((pointer (foreign-slot-value stack-item
- 'smoke-stack-item
- 'voidp))
- (value (convert-from-foreign pointer cffi-type)))
- (when (stack-p type)
- ;; FIXME free-translated-object is not intended for this;
- ;; param is NIL for now.
- (cffi:free-translated-object pointer cffi-type nil))
- value
- ))))
+ (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))
+ (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item
+ 'voidp)))
+ (prog1 (funcall (car translation) pointer)
+ (when (stack-p type)
+ (funcall (cdr translation) pointer))))
+ (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)))
@@ -131,7 +127,8 @@
(10 (foreign-slot-value stack-item 'smoke-stack-item 'float))
(11 (foreign-slot-value stack-item 'smoke-stack-item 'double))
(12 (make-instance 'enum
- :value (foreign-slot-value stack-item 'smoke-stack-item 'enum-value)
+ :value (foreign-slot-value stack-item 'smoke-stack-item
+ 'enum-value)
:type type))))
(defgeneric instance-to-lisp (pointer class type)
@@ -140,19 +137,28 @@
(defun object-to-lisp (object type)
(declare (optimize (speed 3)))
- (if (class-p type)
- (let ((class (get-class type)))
- (if (has-pointer-p object)
+ (let ((class (get-class type)))
+ (if (has-pointer-p object)
+ (if (derived-p (class-of (get-object object))
+ (get-class type))
(get-object object)
- (instance-to-lisp object (find-smoke-class class) type)))
- nil))
+ (progn
+ (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))))
(defun class-to-lisp (stack-item type)
"Returns the Lisp representation for STACK-ITEM of type C++ class."
- (object-to-lisp (foreign-slot-value stack-item
- 'smoke-stack-item
+ (object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item
'class)
type))
@@ -160,9 +166,29 @@
"Returns the Lisp representation of STACK-ITEM"
(declare (optimize (speed 3)))
(cond
- ((void-p type)
- (values))
- ((class-p type)
- (class-to-lisp stack-item type))
- (t
- (enum-to-lisp stack-item type))))
+ ((void-p type) (values))
+ ((class-p type) (class-to-lisp stack-item type))
+ (t (enum-to-lisp stack-item type))))
+
+
+(defun error-no-free (object)
+ (error "Can not free object at ~A." object))
+
+(defmacro define-to-lisp-translation (type-names &optional
+ (conversion-function-name 'identity)
+ (free-function-name 'error-no-free))
+ `(progn ,@(loop for type-name in (ensure-list type-names)
+ collect `(setf (gethash ,type-name *to-lisp-translations*)
+ (cons ',conversion-function-name
+ ',free-function-name)))))
+
+(defmacro define-pointer-typedef (type-names lisp-type)
+ (declare (ignore lisp-type))
+ `(progn
+ (define-to-lisp-translation ,type-names identity identity)))
+ ;; not needed
+ ;;(define-from-lisp-translation ,type-names ,lisp-type)))
+
+(define-to-lisp-translation ("void*" "const void*" "void**"))
+
+(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)
diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp
--- old-smoke/src/objects/type.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/objects/type.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -58,10 +58,9 @@
(type-slot-value type 'name))
(defun smoke-type= (type1 type2)
- (and t ;(pointer-eq (smoke type1)
- ; (smoke type2))
- (= (id type1)
- (id type2))))
+ (if (eq (smoke type1) (smoke type2))
+ (= (id type1) (id type2))
+ (string= (name type1) (name type2))))
(defun get-type-flag (type flag)
(declare (optimize (speed 3)))
@@ -77,8 +76,8 @@
form))
(defmacro allocation-flag-p (type flag)
- ;; Can't just use #'get-type-flag since it
- ;; can only be one of :stack, :reference and :pointer.
+ ;; Can't just use #'get-type-flag since it can only be one of
+ ;; :stack, :reference and :pointer.
;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30)
`(= ,(foreign-enum-value 'smoke-type-flags flag)
(logand #x30
@@ -105,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."
@@ -120,11 +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)))
- (= 0 (mem-ref (mem-aref (smoke-array-pointer
- (smoke-module-types (smoke type)))
- 'smoke-type
- (id type))
- :char)))
+ (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)))
(defgeneric get-class (smoke-symbol)
@@ -132,9 +135,17 @@
(defmethod get-class ((type smoke-type))
"Return the smoke-class of TYPE."
- (assert (/= -1 (type-slot-value type 'class))
+ (assert (class-p type)
(type)
- "The type ~S is not a smoke class." (name type))
- (make-smoke-class-from-id
- (smoke type)
- (type-slot-value type 'class)))
+ "The type ~S is not a smoke class." type)
+ (make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))
+
+;; Return the cffi keyword for the type
+(defun type-foreign-keyword (smoke-type)
+ (intern (nsubstitute #\- #\ (nstring-upcase (name smoke-type)))
+ :keyword))
+
+(defun type-size (smoke-type)
+ (if (class-p smoke-type)
+ (class-size (get-class smoke-type))
+ (foreign-type-size (type-foreign-keyword smoke-type))))
diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp
--- old-smoke/src/overload-resolution.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -1,81 +1,39 @@
;;; C++ overload resolution
;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf
+;;;
+;;; We handle only the most common cases. Stuff like virtual inheritance
+;;; that is not needed is not implemented.
(in-package :smoke)
-(defun cstring= (string1 string2)
- "Returns T when the C strings STRING1 and STRING2 are equal
- and NIL otherwise."
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (i array-total-size-limit)
- (let ((char1 (mem-aref string1 :char i))
- (char2 (mem-aref string2 :char i)))
- (when (/= char1 char2)
- (return-from cstring= nil))
- (when (or (= 0 char1)
- (= 0 char2))
- (return-from cstring= (= char1 char2))))))
-
(declaim (inline cmp))
(defun cmp (a b)
- "Returns -1 if a < b; 0 if a = b and 1 if a > b"
- (declare (values (integer -1 1)))
- (if (< a b)
- -1
- (if (> a b)
- 1
- 0)))
-
-(declaim (inline cstring-cmp))
-(defun cstring-cmp (string1 string2)
- "Compares the C strings STRING1 and STRING2."
- (declare (foreign-pointer string1 string2)
- (values (integer -1 1))
- (optimize (speed 3)))
- (dotimes (i array-total-size-limit (error "omg"))
- (let ((char1 (mem-aref string1 :char i))
- (char2 (mem-aref string2 :char i)))
- (when (/= char1 char2)
- (return-from cstring-cmp (if (< char1 char2) -1 1)))
- (when (= 0 char1) ;; <=> (= 0 char2)
- (return-from cstring-cmp 0)))))
+ (- a b))
+(declaim (inline strcmp))
+(defcfun strcmp :int (s1 :pointer) (s2 :pointer))
+
+(declaim (inline cstring/=))
(defun cstring/= (string1 string2)
"Returns T when the C strings STRING1 and STRING2 are not equal
and NIL otherwise."
- (declare (optimize (speed 3)))
- (dotimes (i array-total-size-limit)
- (let ((char1 (mem-aref string1 :char i))
- (char2 (mem-aref string2 :char i)))
- (when (/= char1 char2)
- (return-from cstring/= i))
- (when (= 0 char1)
- (return-from cstring/= nil)))))
-
-(declaim (inline smoke-method-name))
-(defun smoke-method-name (method)
- (mem-aref (smoke-array-pointer (smoke-module-method-names
- (smoke-method-smoke method)))
- :pointer
- (the (smoke-index 0)
- (method-slot-value method 'name))))
+ (not (zerop (strcmp string1 string2))))
(defun method-cmp (method class-id name)
"Compares METHOD to the method with NAME of class CLASS-ID."
(declare (foreign-pointer name)
(type (smoke-index 0) class-id)
(smoke-method method)
- (values (integer -1 1))
(optimize (speed 3) (debug 0) (safety 0)))
(let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))
(the (smoke-index 0) class-id))))
- (declare (type (integer -1 1) id-cmp)
- (dynamic-extent id-cmp))
+ (declare (type smoke-index id-cmp))
(if (/= 0 id-cmp)
id-cmp
- (cstring-cmp (smoke-method-name method)
+ (strcmp (smoke-method-name method)
name))))
+(declaim (inline first-unabigious-index))
(defun first-unabigious-index (smoke index)
(declare (type smoke-index index)
(optimize (speed 3)))
@@ -94,7 +52,8 @@
(class-id (id class))
(smoke (smoke class))
(end (1+ (smoke-array-length (smoke-module-method-maps smoke)))))
- (declare (type (smoke-index 0) start end))
+ (declare (type (smoke-index 0) start end)
+ (dynamic-extent start))
(loop until (> start end) do
(let* ((index (the smoke-index (floor (+ end start) 2)))
(method (make-smoke-method
@@ -109,23 +68,25 @@
'smoke-method-map index)
'smoke-method-map
'method)))))
- (cmp (the (integer -1 1) (method-cmp method class-id name))))
- (declare (type (integer -1 1) cmp)
- (dynamic-extent method index cmp))
- (ecase cmp
- (-1 (setf start (1+ index)))
- (0 (return-from find-method-for-class index))
- (1 (setf end (1- index)))))))
+ (cmp (the smoke-index (method-cmp method class-id name))))
+ (declare (type smoke-index cmp)
+ (dynamic-extent method))
+ (if (< cmp 0)
+ (setf start (1+ index))
+ (if (> cmp 0)
+ (setf end (1- index))
+ (return-from find-method-for-class index))))))
-1)
-(defmacro push-candidate-method (index name argument-count class methods)
+(defmacro push-candidate-method (index name argument-count class methods
+ const-p)
(with-gensyms (method-map method-index method ambig-index i smoke)
`(let* ((,smoke (smoke ,class))
(,method-map (mem-aref
(smoke-array-pointer
(smoke-module-method-maps ,smoke))
'smoke-method-map
- ,index))
+ (the smoke-index ,index)))
(,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))
(,method (make-smoke-method
:smoke ,smoke
@@ -148,213 +109,192 @@
'smoke-index
,ambig-index))
while (> (the smoke-index ,i) 0) do
- (incf ,ambig-index)
- (push (make-smoke-method :smoke ,smoke
- :id ,i)
- ,methods)))
- (push ,method ,methods)))
+ (incf ,ambig-index)
+ (let ((,method (make-smoke-method :smoke ,smoke
+ :id ,i)))
+ (unless (and ,const-p (not (const-p ,method)))
+ (push ,method ,methods)))))
+ (unless (and ,const-p (not (const-p ,method)))
+ (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)
- "Returns a list of methods named NAME that take ARGUMENT-COUNT methods."
- ;; 13.3.2
- ;; FIXME make a lazy map-viable-functions to allow returning early,
- ;; when an exact match is found.
+(defun viable-functions (name argument-count class &optional const-p)
(declare (optimize (speed 3)))
(with-foreign-string (name name)
- (let ((methods)
- (smoke (smoke class)))
- (dolist (class (all-smoke-superclasses class))
+ (let ((methods))
+ (let ((smoke (smoke class)))
(let ((start-index (find-method-for-class name class)))
(declare (type smoke-index start-index))
- (loop for index from start-index downto 1
- while (push-candidate-method index name argument-count class
- methods))
- (loop for index from (1+ start-index)
- to (the smoke-index (smoke-array-length
- (smoke-module-method-maps smoke)))
- while (push-candidate-method index name argument-count class
- methods))))
+ (when (>= start-index 0)
+ (loop for index from start-index downto 1
+ while (push-candidate-method index name argument-count class
+ methods const-p))
+ (loop for index from (1+ start-index)
+ to (the smoke-index (smoke-array-length
+ (smoke-module-method-maps smoke)))
+ while (push-candidate-method index name argument-count class
+ methods const-p)))))
methods)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defconstant +exact-match+ 0)
-(defconstant +promotion+ 1)
-(defconstant +conversion+ 2))
-
-(defclass std-conversion ()
- ((function-name :accessor conversion-function-name
- :initarg :conversion-function-name))
- (:documentation "A conversion"))
-
-(defclass exact-match (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform +exact-match+)))
-
-(defclass promotion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform +promotion+)))
-
-(defclass number-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform +conversion+)))
-
-(defclass pointer-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform (1+ +conversion+))
- (from :reader from
- :initarg :from)
- (to :reader to
- :initarg :to)))
-
-(defclass boolean-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform (+ 2 +conversion+))))
-
-(defclass user-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform (+ 3 +conversion+))))
-
-(defgeneric conversion< (conversion1 conversion2)
- (:documentation
- "Returns true when CONVERSION1 is better than CONVERSION2.")
+(declaim (inline make-conversion make-exact-match make-promotion
+ make-number-conversion make-pointer-conversion
+ make-boolean-conversion make-user-conversion))
+(defstruct conversion
+ (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))))
+
+(defstruct (promotion (:include conversion (rank 1))))
+
+(defstruct (number-conversion (:include conversion (rank 2))))
+
+(defstruct (pointer-conversion (:include conversion (rank 3)))
+ (from (find-class t) :type class :read-only t)
+ (to (find-class t) :type class :read-only t))
+
+(defstruct (boolean-conversion (:include conversion (rank 4))))
+
+(defstruct (user-conversion (:include conversion (rank 5))))
+
+(defgeneric conversion<= (conversion1 conversion2)
;; 13.3.3.2 Ranking implicit conversion sequences
;; 4
(:method (conversion1 conversion2)
(declare (optimize (speed 3)))
- (or (null conversion2)
- (< (the fixnum (rank conversion1))
- (the fixnum (rank conversion2)))))
+ (and (not (null conversion1))
+ (or (null conversion2)
+ (<= (the fixnum (conversion-rank conversion1))
+ (the fixnum (conversion-rank conversion2))))))
(:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
(declare (optimize (speed 3)))
- (if (eq (from conversion1) (from conversion2))
+ (if (eq (pointer-conversion-from conversion1)
+ (pointer-conversion-from conversion2))
;; A->B < A->C <=> B subclass of C
- (subtypep (to conversion1) (to conversion2))
- (if (eq (to conversion1) (to conversion2))
+ (subtypep (pointer-conversion-to conversion1)
+ (pointer-conversion-to conversion2))
+ (if (eq (pointer-conversion-to conversion1)
+ (pointer-conversion-to conversion2))
;; B->A < C->A <=> B subclass of C
- (subtypep (from conversion1) (from conversion2))
+ (subtypep (pointer-conversion-from conversion1)
+ (pointer-conversion-from conversion2))
nil))))
(defgeneric conversion= (conversion1 conversion2)
- (:documentation
- "Returns true when the standard conversion sequence CONVERSION1
- is indistinguishable from CONVERSION2.")
(:method (conversion1 conversion2)
- (= (rank conversion1) (rank conversion2)))
+ (and (conversion<= conversion1 conversion2)
+ (conversion<= conversion2 conversion1)))
(:method ((conversion1 (eql nil)) (conversion2 (eql nil)))
- t)
- (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
- (and (not (conversion< conversion1 conversion2))
- (not (conversion< conversion2 conversion1)))))
+ t))
(defun max-conversion (conversion1 conversion2)
"Returns the greater conversion of CONVERSION1 and CONVERSION2."
(if (null conversion2)
conversion1
- (if (conversion< conversion1 conversion2)
+ (if (conversion<= conversion1 conversion2)
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)
- `(make-instance ,type
- :conversion-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
to an instance of type TYPE. When USER is true user conversions are considered."
- (if-let
- (match (call-using-type exact-match object type))
- (if (eql t match)
- (make-match 'exact-match)
- (make-match 'exact-match match))
- (or (call-using-type promotion object type)
- (call-using-type conversion object type)
- (and user
- (call-using-type user-conversion object type)))))
+ (if-let (match (call-using-type exact-match object type))
+ (if (eql t match)
+ (make-match 'exact-match)
+ (make-match 'exact-match match))
+ (or (call-using-type promotion object type)
+ (call-using-type conversion object type)
+ (and user
+ (call-using-type user-conversion object type)))))
(defun+using-types standard-conversion-sequence (method classes &optional user)
"Returns the conversion sequences to convert the arguments of types CLASSES
to the types required by METHOD."
- (let ((max-rank)
- (conversions))
- (loop for type in (arguments method)
- for class in classes do
- (let ((rank (call-using-type get-conversion-sequence class type user)))
- (when (null rank)
- (setf max-rank nil)
- (return nil))
- (setf max-rank (max-conversion rank max-rank))
- (push (conversion-function-name rank) conversions)))
- (values max-rank (reverse conversions))))
+ (if (null classes)
+ (values (make-match 'exact-match) nil)
+ (let ((max-rank)
+ (conversions))
+ (loop for type in (arguments method)
+ for class in classes do
+ (let ((rank (call-using-type get-conversion-sequence class type user)))
+ (when (null rank)
+ (setf max-rank nil)
+ (return nil))
+ (setf max-rank (max-conversion rank max-rank))
+ (push (conversion-function-name rank) conversions)))
+ (values max-rank (reverse conversions)))))
(defun+using-types conversion-sequence (method classes)
(call-using-types standard-conversion-sequence method classes t))
-(defun+using-types find-best-viable-function (name arguments class)
+(defun+using-types find-best-viable-function (name arguments class
+ &optional const-p)
"Returns the method named NAME of class CLASS that can be called
using arguments of types TYPES with the lowest conversion sequence."
(call-using-types find-best-viable-function2
(function-using-types conversion-sequence)
- name arguments class))
+ name arguments class const-p))
-(defun+using-types find-best-viable-function2 (get-sequence name objects class)
- (declare (type (function (t list) (values t function)) get-sequence))
+(defun+using-types find-best-viable-function2 (get-sequence name objects class
+ &optional const-p)
(when (and (using-typep)
(not (typep class 'smoke-standard-class)))
(throw 'unspecific-type class))
(let ((viable-functions (viable-functions name (length objects)
- class))
+ class const-p))
(best-rank)
(best-method)
(conversions))
- (loop for method in viable-functions do
- (multiple-value-bind (rank method-conversions)
- (funcall get-sequence method objects)
- ;; FIXME test for ambiguous overload #'conversion=
- (when (and rank (conversion< rank best-rank))
- (setf best-rank rank)
- (setf best-method method)
- (setf conversions method-conversions)
- (when (conversion= rank (make-match 'exact-match))
- (return)))))
- (values best-method conversions)))
+ (if (null viable-functions)
+ (dolist (class (closer-mop:class-direct-superclasses class)
+ (values best-method nil))
+ (when (typep class 'smoke-standard-class)
+ (multiple-value-bind (method conversions)
+ (call-using-types find-best-viable-function2 get-sequence name objects class const-p)
+ (when method
+ (return (values method conversions))))))
+ (loop for method in viable-functions
+ finally (return (values best-method conversions)) do
+ (block next
+ (multiple-value-bind (rank method-conversions)
+ (funcall get-sequence method objects)
+ (when (and rank (conversion<= rank best-rank))
+ (when (conversion= rank best-rank)
+ ;; FIXME catch all ambigious overloads
+ (if const-p
+ (error "Ambigious overload ~A." method)
+ (when (const-p method)
+ ;; assume that the previous method is a non
+ ;; const one and thus more specific.
+ (return-from next))))
+ (setf best-rank rank)
+ (setf best-method method)
+ (setf conversions method-conversions)
+ (when (and (conversion= rank (make-match 'exact-match))
+ (not (xor const-p (const-p method))))
+ (return (values method conversions))))))))))
(defvar *from-lisp-translations* (make-hash-table :test 'equal))
@@ -365,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**")
@@ -386,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)))
@@ -394,9 +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 '(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))))))
@@ -416,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))
@@ -430,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)
@@ -446,7 +411,8 @@
(defun+using-type conversion-cast object (object type)
(when (and (class-p type)
(object.typep 'smoke-standard-object)
- (derived-p (object.type-of) (get-class type)))
+ (derived-p (object.type-of) (get-class type))
+ (find-smoke-class (get-class type)))
(make-match 'pointer-conversion
'coerce-cast
(find-smoke-class (get-class type))
@@ -463,21 +429,24 @@
:to (find-class 't))))
(defun+using-type conversion-pointer object (object type)
- ;; Not using pointer-p to allow passing a raw pointer for
- ;; objects on the stack and references
+ ;; Not using pointer-p to allow passing a raw pointer for objects on
+ ;; the stack and references.
;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )
;;
- ;; FIXME this breaks passing pointers to references
- ;; e.g.: calling the function foo(QByteArray& foo)
- ;; with (foo pointer) assumes pointer to point to a QByteArray,
- ;; but actually the conversion sequence QByteArray(pointer) should be used.
- ;; When pointer is a null pointer it fails horribly!.
+ ;; FIXME this breaks passing pointers to references.
+ ;;
+ ;; e.g.: calling the function foo(QByteArray& foo) with
+ ;; (foo pointer) assumes pointer to point to a QByteArray, but
+ ;; actually the conversion sequence QByteArray(pointer) should be
+ ;; used. When pointer is a null pointer it fails horribly!.
+ ;;
+ ;; But it is needed for passing the int pointer in QApplication(int&, char**).
(when (and (or (= 0 (type-id type)) ; voidp
(= 13 (type-id type))) ; class
(object.typep 'foreign-pointer))
(make-match 'pointer-conversion 'identity nil
- :from (find-class 't)
- :to (find-class 't)))) ;; FIXME get the class when applicable
+ :from (find-class 't)
+ :to (find-class 't)))) ;; FIXME get the class when applicable
(defun+using-type conversion object (object type)
@@ -489,20 +458,27 @@
(or (call-using-type operator-conversion object type)
(call-using-type constructor-conversion object type)))
+(defun conversion-operator-name (to-type)
+ (concatenate 'string
+ "operator "
+ (if (class-p to-type)
+ (name (get-class to-type))
+ (name to-type))))
+
+(defun coerce-to-type (object method)
+ (pointer-call method (pointer object)))
+
(defun+using-type operator-conversion object (object type)
(when (object.typep 'smoke-standard-object)
(let ((method (find-smoke-method (object.type-of)
- (format nil "operator ~A"
- (if (class-p type)
- (name (get-class type))
- (name type))))))
+ (conversion-operator-name type))))
(when (valid-p method)
- (assert (not (void-p type))
- ()
- "Conversion operators not supported by Smoke.
-Update to Smoke >= r955426.")
- (make-match 'user-conversion
- (lispify (name method) :cxx))))))
+ (if (pointer-p type)
+ (make-match 'user-conversion
+ 'coerce-to-type
+ method)
+ (make-match 'user-conversion
+ (lispify (name method) :cxx)))))))
(declaim (inline coerce-to-class))
(defun coerce-to-class (object to-class)
@@ -511,16 +487,21 @@
(defun+using-type constructor-conversion object (object type)
(when (class-p type)
- (let ((to-class (find-smoke-class (get-class type))))
- (when (call-using-types find-best-viable-function2
- (if (using-typep)
- #'standard-conversion-sequence-using-types
- #'standard-conversion-sequence)
- (format nil "~A" (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
@@ -547,31 +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)))
- (if (null arguments)
- (let ((method (find-smoke-method (smoke-class-of object-or-class)
- name)))
- (unless (valid-p method)
- (error (make-condition 'no-applicable-cxx-method
- :method name
- :class object-or-class
- :arguments arguments)))
- (if (static-p method)
- (s-call method (null-pointer))
- (s-call method (cast object-or-class (get-class method)))))
- (multiple-value-bind (method sequence)
- (find-best-viable-function name
- arguments
- (smoke-class-of 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)))))
+ (declare (optimize (speed 3))
+ (type (or smoke-standard-class smoke-standard-object)
+ object-or-class))
+ (multiple-value-bind (method sequence)
+ (#-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)))
+ (apply #'call-sequence method
+ (if (static-p method)
+ (null-pointer)
+ (cast object-or-class (get-class method)))
+ sequence arguments)))
+
+(defmethod slot-missing (meta-class (class smoke-standard-class) slot-name operation &optional new-value)
+ (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))
+ (if (or (not (valid-p method)) (not (static-p method)))
+ (call-next-method)
+ (ecase operation
+ (setf
+ (handler-case (funcall (fdefinition
+ (intern
+ (concatenate 'string "SET-"
+ (string-upcase
+ (string slot-name)))
+ :cxx))
+ class new-value)
+ (undefined-function ()
+ (error "The C++ attribute ~A of ~A is read only." slot-name class))
+ (no-applicable-cxx-method (condition)
+ (if (null (viable-functions (condition-method condition)
+ (length (condition-arguments condition))
+ (condition-class condition)))
+ (error "The C++ attribute ~A of ~A is read only." slot-name class)
+ (error condition)))))
+ (slot-boundp t)
+ (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name class))
+ (slot-value (s-call method (null-pointer)))))))
+
+(defmethod slot-missing ((class smoke-standard-class) object slot-name operation &optional new-value)
+ (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))
+ (if (not (valid-p method))
+ (call-next-method)
+ (ecase operation
+ (setf
+ (handler-case (funcall (fdefinition
+ (intern
+ (concatenate 'string "SET-"
+ (string-upcase
+ (string slot-name)))
+ :cxx))
+ object new-value)
+ (undefined-function ()
+ (error "The C++ attribute ~A of ~A is read only." slot-name object))
+ (no-applicable-cxx-method (condition)
+ (if (null (viable-functions (condition-method condition)
+ (length (condition-arguments condition))
+ (condition-class condition)))
+ (error "The C++ attribute ~A of ~A is read only." slot-name object)
+ (error condition)))))
+ (slot-boundp t)
+ (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name object))
+ (slot-value (s-call method (cast object (get-class method))))))))
diff -rN -u old-smoke/src/package.lisp new-smoke/src/package.lisp
--- old-smoke/src/package.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/package.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -13,28 +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
- #:make-cleanup-pointer
+ #:define-to-lisp-translation
+ #:*to-lisp-translations*
- #:pointer
+ #:define-pointer-typedef
#:define-smoke-module
+
#:define-takes-ownership
+ #:delete-object
+ #:remove-object
+
+ #:eval-startup
+
+ #:get-smoke-variable-for-pointer
+ #:init
+ #:object-to-lisp
+
+ #:make-auto-pointer
+ #:make-cleanup-pointer
+
+ #:make-smoke-classes
+ #:make-smoke-type
+ #:no-applicable-cxx-method
+ #:smoke-call
+ #:upcast
+
+ #:smoke-standard-object
+ #:smoke-type
+ #:smoke-type=
#+sbcl #:save-bundle))
diff -rN -u old-smoke/src/sb-optimize.lisp new-smoke/src/sb-optimize.lisp
--- old-smoke/src/sb-optimize.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/sb-optimize.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -0,0 +1,159 @@
+(in-package :smoke)
+
+(declaim (optimize (debug 3)))
+
+(defmacro catch-try ((tag &optional catch-result) catch-form &body body)
+ "Catch TAG in the BODY forms. When TAG is throw CATCH-RESULT is bound
+to the thrown values and result of CATCH-FORM is returned. Otherwise
+the result of BODY is returned and CATCH-FORM is not evaluated."
+ (flet ((catch-block (tag return-block body)
+ `(catch ,tag
+ (return-from ,return-block
+ ,@body))))
+ (let ((return-block (gensym)))
+ `(block ,return-block
+ ,(if catch-result
+ `(let ((,catch-result ,(catch-block tag return-block body)))
+ ,catch-form)
+ `(progn ,(catch-block tag return-block body)
+ ,catch-form))))))
+
+(defun type-specifier (lvar)
+ (let ((type (sb-kernel:type-specifier (sb-c::lvar-type lvar))))
+ (if (subtypep type 'smoke-standard-object)
+ (find-class type)
+ type)))
+
+
+(defun give-up-transform (&rest args)
+ (apply #'sb-c::give-up-ir1-transform args))
+
+(defmacro define-transform (name lambda-list &body body)
+ `(sb-c:deftransform ,name (,lambda-list)
+ ,@body))
+
+(defmacro define-known (name)
+ `(sb-c:defknown ,name * *))
+
+(defun method-form (method)
+ `(make-smoke-method
+ :id ,(id method)
+ :smoke (eval ,(get-smoke-variable-for-pointer
+ (smoke method)))))
+
+(defun sequence-form (sequence arguments)
+ (mapcar #'(lambda (sequence argument)
+ (if (symbolp sequence)
+ `(,sequence ,argument)
+ `(,(first sequence) ,argument ,@(rest sequence))))
+ sequence arguments))
+
+
+(defmacro define-resolve-at-compile-time (gf-name)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (define-known ,gf-name)
+ (sb-c:defoptimizer (,gf-name derive-type) ((object &rest args))
+ (catch-try ('unspecific-type) sb-c::*wild-type*
+ (let ((method (find-best-viable-function-using-types
+ ,(name (fdefinition gf-name))
+ (mapcar #'type-specifier args) (type-specifier object))))
+ (if (and method (class-p (return-type method)))
+ (sb-kernel:single-value-specifier-type
+ (find-smoke-class (get-class (return-type method))))
+ sb-c::*wild-type*))))
+ (define-transform ,gf-name (object &rest args)
+ (when (null args)
+ (give-up-transform "No arguments."))
+ (catch-try ('unspecific-type reason)
+ (give-up-transform "Could not resolve overload at compile time: ~A" reason)
+ (multiple-value-bind (method sequence)
+ (find-best-viable-function-using-types
+ ,(name (fdefinition gf-name))
+ (mapcar #'type-specifier args)
+ (type-specifier object))
+ (let ((argument-names (make-gensym-list (length args))))
+ (when (null method)
+ (give-up-transform "No applicable method."))
+ (if (static-p method)
+ `(s-call ,(method-form method)
+ (null-pointer)
+ (list ,@(sequence-form
+ sequence args)))
+ `(lambda (object ,@argument-names)
+ (s-call ,(method-form method)
+ ,(if (eql (type-specifier object)
+ (find-smoke-class (get-class method)))
+ `(pointer object)
+ `(cast object
+ (find-class (quote ,(class-name
+ (find-smoke-class
+ (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))
diff -rN -u old-smoke/src/smoke-c/CMakeLists.txt new-smoke/src/smoke-c/CMakeLists.txt
--- old-smoke/src/smoke-c/CMakeLists.txt 2014-10-30 08:13:11.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)
diff -rN -u old-smoke/src/smoke-c/cl_smoke.h new-smoke/src/smoke-c/cl_smoke.h
--- old-smoke/src/smoke-c/cl_smoke.h 2014-10-30 08:13:11.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
diff -rN -u old-smoke/src/smoke-c/class.lisp new-smoke/src/smoke-c/class.lisp
--- old-smoke/src/smoke-c/class.lisp 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/src/smoke-c/csmokebinding.cpp new-smoke/src/smoke-c/csmokebinding.cpp
--- old-smoke/src/smoke-c/csmokebinding.cpp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/smoke-c/csmokebinding.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,85 +0,0 @@
-#include "csmokebinding.h"
-
-#include <QtGlobal>
-
-namespace cl_smoke
-{
-
-/** @class Binding
- * @brief The Smoke binding.
- */
-
-
-/** @typedef Binding::destructed
- * Callback when a Smoke object is destructed.
- *
- * @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
diff -rN -u old-smoke/src/smoke-c/csmokebinding.h new-smoke/src/smoke-c/csmokebinding.h
--- old-smoke/src/smoke-c/csmokebinding.h 2014-10-30 08:13:11.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
diff -rN -u old-smoke/src/smoke-c/method.lisp new-smoke/src/smoke-c/method.lisp
--- old-smoke/src/smoke-c/method.lisp 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/src/smoke-c/smoke-c-util.cpp new-smoke/src/smoke-c/smoke-c-util.cpp
--- old-smoke/src/smoke-c/smoke-c-util.cpp 2014-10-30 08:13:11.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"
diff -rN -u old-smoke/src/smoke-c/smoke-c.cpp new-smoke/src/smoke-c/smoke-c.cpp
--- old-smoke/src/smoke-c/smoke-c.cpp 2014-10-30 08:13:11.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"
diff -rN -u old-smoke/src/smoke-c/smoke-c.lisp new-smoke/src/smoke-c/smoke-c.lisp
--- old-smoke/src/smoke-c/smoke-c.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/smoke-c/smoke-c.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,83 +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))
diff -rN -u old-smoke/src/smoke-c/stack.lisp new-smoke/src/smoke-c/stack.lisp
--- old-smoke/src/smoke-c/stack.lisp 2014-10-30 08:13:10.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.")
diff -rN -u old-smoke/src/smoke-c/type.lisp new-smoke/src/smoke-c/type.lisp
--- old-smoke/src/smoke-c/type.lisp 2014-10-30 08:13:11.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))
diff -rN -u old-smoke/src/smoke-to-clos.lisp new-smoke/src/smoke-to-clos.lisp
--- old-smoke/src/smoke-to-clos.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/smoke-to-clos.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -0,0 +1,180 @@
+(in-package :smoke)
+
+(defun constant-definition (package method smoke)
+ "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 (or (string= (name (get-class method))
+ "Qt")
+ (string= (name (get-class method))
+ "QGlobalSpace"))
+ (lispify (concatenate 'string "+" (name method)
+ "+")
+ package)
+ (lispify (concatenate 'string
+ (name (get-class method))
+ ".+"
+ (name method) "+")
+ package))))
+ (values
+ (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)
+ "Returns the lisp symbol for the static method METHOD."
+ (let ((class (get-class method)))
+ (lispify (concatenate 'string
+ (if (string= (name class)
+ "QGlobalSpace")
+ nil
+ (concatenate 'string
+ (name class)
+ "."))
+ (name method))
+ package)))
+
+(defun static-method-definition (package method &optional (argument-count -1))
+ "Returns an expression to define a function for the static METHOD.
+The second return value is the expression to export the function."
+ (let* ((class (get-class method))
+ (method-name (name method))
+ (name (static-method-symbol package method)))
+ (values
+ `(defun ,name ,(if (< argument-count 0)
+ '(&rest args)
+ (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)
+ "Ensures the generic functions for SYMBOLS-NAMES."
+ (declare (list symbols-names)
+ (optimize (speed 3)))
+ (dolist (symbol-name symbols-names)
+ (ensure-generic-function (first symbol-name)
+ :cxx-name (rest symbol-name)
+ :generic-function-class 'smoke-gf
+ :lambda-list '(object &rest args))
+ (export (first symbol-name) :cxx)))
+
+(defun setf-method-definition (method)
+ `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
+ (,(lispify (name method) :cxx) object new-value)
+ new-value))
+
+(defmacro sizes= ((smoke)&rest arrays)
+ `(and ,@(loop for array in arrays collect
+ `(= (smoke-array-length (,array ,smoke))
+ ,(smoke-array-length (funcall (fdefinition array)
+ (eval smoke)))))))
+
+(defmacro check-recompile (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.
+Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods
+and a function do define the generic methods a load-time."
+;;; symbol - id pairs are stored in the hash-tables to prevent the
+;;; multiple definition of a function with the same name.
+ (let ((generics (make-hash-table))
+ (constants)
+ (functions)
+ (function-symbols (make-hash-table))
+ (setf-function-symbols (make-hash-table))
+ (exports))
+ (map-methods
+ #'(lambda (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)
+ (push export exports)))
+ (when (and (not (destructor-p method))
+ (not (constructor-p method))
+ (not (enum-p method))
+ (not (eql nil (name method)))
+ (string/= (name method) "tr")) ;; we have a custom qt:tr function
+ (let ((name (name method)))
+ (when (and (starts-with-subseq "set" name)
+ (> (length name) 3)
+ (upper-case-p (char name 3))
+ (= 1 (get-arguments-length method)))
+ (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)))
+ (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)))
+ (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
+ :smoke (eval smoke)
+ :id (abs id))))
+ (multiple-value-bind (definition export)
+ (static-method-definition
+ package
+ method
+ (if (< 0 id)
+ (get-arguments-length method)
+ -1))
+ (push definition functions)
+ (push export exports))))
+ `(progn (check-recompile ,smoke)
+ ,@functions
+ (eval-startup (:compile-toplevel :load-toplevel :execute)
+ ;; FIXME when loading the Lisp image we no longer need
+ ;; to call #'ensure-class, but the class-map needs still
+ ;; to be populated by #'add-id-class-map and #'add-id;
+ ;; For now we ignore the negligible overhead.
+ (make-smoke-classes ,package ,smoke))
+ (eval-when (:load-toplevel :execute)
+ (ensure-generic-methods ',(hash-table-alist generics)))
+ ,@constants
+ (eval-when (:load-toplevel :execute)
+ (export (quote ,exports) ,package)))))
+
diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp
--- old-smoke/src/smoke.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/smoke.lisp 2014-10-30 08:13:11.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
@@ -30,149 +30,137 @@
(declaim (inline call-s-method))
(defun call-s-method (method object-pointer stack-pointer)
(foreign-funcall-pointer
- (foreign-slot-value (pointer (get-class method))
- 'smoke-class
- 'class-function)
+ (foreign-slot-value (smoke-class-pointer (get-class method))
+ 'smoke-class 'class-function)
()
smoke-index (foreign-slot-value (smoke-method-pointer method)
- 'smoke-method
- 'method)
+ 'smoke-method 'method)
:pointer object-pointer
smoke-stack stack-pointer
:void))
(defun s-call (method object-pointer &optional (args nil))
(with-stack (stack args (arguments method) )
- (call-s-method method object-pointer (pointer stack))
- (type-to-lisp (pointer stack) (return-type method))))
+ (call-s-method method object-pointer (call-stack-pointer stack))
+ (type-to-lisp (call-stack-pointer stack) (return-type method))))
(defun pointer-call (method object-pointer &optional (args nil))
(with-stack (stack args (arguments method) )
- (call-s-method method object-pointer (pointer stack))
- (foreign-slot-value (pointer stack) 'smoke-stack-item 'class)))
-
+ (call-s-method method object-pointer (call-stack-pointer stack))
+ (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class)))
(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))
+ (s-call (make-smoke-method-from-name class method-name) pointer args))
(defun enum-call (method)
"Return the enum value for METHOD."
;; FIXME:
+ ;;
;; we could use static call, but QGraphicsEllipseItem::Type has
;; wrongly QGraphicsGridLayout as return type. Smoke ignores case
- ;; and confuses it with the member function type() ??
- ;; (27.2.09)
+ ;; and confuses it with the member function type() ?? (27.2.09)
;;
(assert (enum-p method))
(with-stack (stack nil nil)
- (call-s-method method (null-pointer) (pointer stack))
- (foreign-slot-value (pointer stack) 'smoke-stack-item 'long)))
+ (call-s-method method (null-pointer) (call-stack-pointer stack))
+ (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'long)))
(defun delete-pointer (pointer class)
"Destructs the object at POINTER of type CLASS.
Calls the destructor and frees the memory."
(declare (optimize (speed 3)))
- (let ((method-name (concatenate 'string "~" (name class))))
- (s-call
- (make-smoke-method-from-name class method-name)
- pointer))
- (setf pointer (null-pointer)))
+ (let ((method-name (concatenate 'string "~" (constructor-name class))))
+ (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 (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))) pointer-symbol-map)
+ (setf (gethash (pointer-address (smoke-module-pointer (eval symbol)))
+ pointer-symbol-map)
symbol))
(defun get-smoke-variable-for-pointer (pointer)
"Returns the SYMBOL of the variable whose value is POINTER."
(gethash (pointer-address pointer) pointer-symbol-map)))
(defun call (object method-name &rest args)
- (smoke-call (class-of object)
- (pointer object)
- method-name
- args))
+ (smoke-call (class-of object) (pointer object)
+ method-name args))
(defmethod documentation ((class smoke-standard-class) (doc-type (eql 't)))
(declare (optimize (speed 3)))
(format nil "~@[~A~%~]C++ name: ~A" (call-next-method) (name class)))
-;; No eql T since all-methods is to slow to be used in conjunction with
-;; mb:document
-(defmethod documentation ((gf smoke-gf) (doc-type (eql 'cxx-function)))
+(defmethod documentation ((gf smoke-gf) (doc-type (eql 't)))
(declare (optimize (speed 3)))
(let ((methods (all-methods (name gf))))
(format nil "~@[~A~%~]~{~T~A~%~}"
(call-next-method)
(sort (mapcar #'method-declaration methods) #'string<=))))
+(declaim (inline cstring=))
+(defun cstring= (string1 string2)
+ "Returns T when the C strings STRING1 and STRING2 are equal
+ and NIL otherwise."
+ (zerop (strcmp string1 string2)))
+
(defun all-methods (name)
"Returns a list of all methods named NAME."
- ;;FIXME speed this up, needed by (mb:document :smoke).
- (declare (string name)
- (optimize (speed 3)))
+ (declare (optimize (speed 3)))
+ (with-foreign-string (name name)
(let ((methods))
(maphash
- #'(lambda (address value)
- (declare (ignore value))
- (let ((smoke (make-pointer address)))
- (map-methods #'(lambda (method)
- (when (and (string= name (name method))
- (not (enum-p method)))
- (push (make-instance 'smoke-method
- :id (smoke-method-id method)
- :smoke (smoke method))
- methods)))
- smoke)))
- *smoke-id-class-map*)
- methods))
+ #'(lambda (address module)
+ (declare (ignore address))
+ (map-methods #'(lambda (method)
+ (when (and (cstring= name (smoke-method-name method))
+ (not (enum-p method)))
+ (push (make-smoke-method
+ :id (smoke-method-id method)
+ :smoke (smoke-method-smoke method))
+ methods)))
+ module))
+ *smoke-modules*)
+ methods)))
(defun fgrep-methods (smoke str)
(map-methods #'(lambda (method)
@@ -187,25 +175,18 @@
"Define a Smoke module."
(let ((smoke-module (intern "*SMOKE-MODULE*")))
`(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (define-foreign-library ,library
- (:unix ,(format nil "~(~A~).so.2" library))
- (t (:default ,(format nil "~(~A~)" library)))))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (define-foreign-library ,library
+ (:darwin ,(format nil "~(~A~).3.dylib" library))
+ (:unix ,(format nil "~(~A~).so.3" library))
+ (t (:default ,(format nil "~(~A~)" library)))))
(eval-startup (:compile-toplevel :execute)
- (load-foreign-library ',library))
+ (load-foreign-library ',library))
+
(eval-startup (:compile-toplevel :execute)
-; (eval-when (:compile-toplevel :load-toplevel :execute)
-; (define-foreign-library ,library
-; (:unix ,(format nil "~(~A~).so.2" library))
-; (t (:default ,(format nil "~(~A~)" library))))
-; (load-foreign-library ',library))
- (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)
+ (defcvar (,variable ,variable-name :read-only t :library ,library)
+ :pointer)
+ (defcfun (,init-function ,function-name :library ,library)
:void))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,smoke-module (make-smoke-module)))
@@ -215,7 +196,6 @@
(register-smoke-module-var ',smoke-module))
(define-classes-and-gfs ,package ,smoke-module))))
-
(defun fgrep-classes (smoke str)
(map-classes #'(lambda (class)
(when (search str (name class))
diff -rN -u old-smoke/src/translate.lisp new-smoke/src/translate.lisp
--- old-smoke/src/translate.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/translate.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,27 +0,0 @@
-(in-package :smoke)
-
-(defvar *type-map* (make-hash-table :test 'equal))
-
-(defun get-type (name)
- "Return the CFFI type for NAME."
- (gethash name *type-map*))
-
-(defun add-type (name type)
- "Registers the CFFI type TYPE with NAME."
- (setf (gethash name *type-map*) type))
-
-(defun setup-type-map ()
- "Setup C string <-> Lisp string translation."
- (add-type "char*" :string)
- (add-type "const char*" :string))
-
-(eval-when (:load-toplevel :execute)
- (setup-type-map))
-
-(defgeneric convert-to-class (smoke-class object))
-
-;(defmethod convert-to-class (smoke-class (pointer cffi:foreign-pointer))
-(defmethod convert-to-class (smoke-class pointer)
- (declare (ignore smoke-class))
- (assert (cffi:pointerp pointer))
- pointer)
diff -rN -u old-smoke/src/using-type.lisp new-smoke/src/using-type.lisp
--- old-smoke/src/using-type.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/src/using-type.lisp 2014-10-30 08:13:11.000000000 +0100
@@ -13,12 +13,11 @@
`(,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,
-false when it is not; and :MAYBE when the relationship
-could not be determined."
+false when it is not."
(declare (values (member t nil :maybe)))
(multiple-value-bind (subtype-p valid-p)
(subtypep object-type type)
@@ -30,7 +29,10 @@
(if subtype-p
(throw 'unspecific-type (values object-type type))
(if valid-p
- nil
+ (if (and (subtypep type 'integer)
+ (not (integer-types-disjunct-p object-type type)))
+ (throw 'unspecific-type (values object-type type))
+ nil)
(throw 'unspecific-type (values object-type type)))))
(throw 'unspecific-type (values object-type))))))
@@ -57,7 +59,6 @@
(with-object-as-object ,object
(defun ,name ,lambda-list
,@body))
- #+nil
(with-object-as-type ,object
(defun ,(symbolicate name '-using-type) ,lambda-list
,@body))))
@@ -72,7 +73,6 @@
`(function ,name)))
(defun ,name ,lambda-list
,@body))
- #+nil
(macrolet ((call-using-types (function-name &rest args)
`(,(symbolicate function-name '-using-types)
,@args))
@@ -84,3 +84,8 @@
`(function ,(symbolicate name '-using-types))))
(defun ,(symbolicate name '-using-types) ,lambda-list
,@body))))
+
+(defun integer-types-disjunct-p (type1 type2)
+ ;; FIXME implement this
+ (declare (ignore type1 type2))
+ nil)
diff -rN -u old-smoke/test-bundle.sh new-smoke/test-bundle.sh
--- old-smoke/test-bundle.sh 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/test-bundle.sh 2014-10-30 08:13:11.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
diff -rN -u old-smoke/test.lisp new-smoke/test.lisp
--- old-smoke/test.lisp 2014-10-30 08:13:11.000000000 +0100
+++ new-smoke/test.lisp 2014-10-30 08:13:11.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)