Tue Jul 13 21:17:41 CEST 2010 Tobias Rautenkranz * Use libsmokebase instead of libsmokeqtcore. Sat Apr 3 21:11:26 CEST 2010 Tobias Rautenkranz * slot-value access for static attributes using the class instead of an object. Sat Apr 3 14:04:39 CEST 2010 Tobias Rautenkranz * Make the slot-* functions work for C++ class attributes. Allow slot-value to be used to access C++ member variables of objects. Sat Apr 3 14:03:07 CEST 2010 Tobias Rautenkranz * Fix attribute vs method map to same Lisp name clash. e.g.: setWidget() and set_widget are in Lisp both #'set-widget. Prefer the method over the attribute; the attribute will be accessible with SLOT-VALUE. Wed Mar 10 17:38:58 CET 2010 Tobias Rautenkranz * Improve missing to-lisp-translator error message. Sat Feb 20 21:56:27 CET 2010 Tobias Rautenkranz * Allow passing integers as enum arguments. Sat Feb 20 19:01:21 CET 2010 Tobias Rautenkranz * Fix overload resolution exact match for long and ulong. Sat Feb 20 18:56:48 CET 2010 Tobias Rautenkranz * Faster no overload resolution method lookup. Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz * Cache overload resolution on sbcl Fri Feb 19 22:22:50 CET 2010 Tobias Rautenkranz * cleanup #'delete-object & optimize #'constructor-name. Fri Feb 19 22:10:24 CET 2010 Tobias Rautenkranz * No need to construct a SmokeBinding per Smoke module. Thu Feb 18 20:57:00 CET 2010 Tobias Rautenkranz * Don't dispatch virtual methods for builtin classes (reduces overhead). Thu Feb 18 19:31:47 CET 2010 Tobias Rautenkranz * Fix casting across Smoke modules. Wed Feb 17 18:05:35 CET 2010 Tobias Rautenkranz * Remove underlinking of libclsmoke and add a darwin case to the library definitons. Thanks to Elliott Slaughter Tue Feb 16 22:56:19 CET 2010 Tobias Rautenkranz * Load libsmokeqtcore instead of qt in the default case of cffi:define-foreign-library. Tue Feb 16 22:52:02 CET 2010 Tobias Rautenkranz * Fix derived-p for classes that are external in every module. Mon Feb 15 16:31:33 CET 2010 Tobias Rautenkranz * Build a shared library not a module. Fixes on build error on OS X as reported by Elliott Slaughter. Mon Feb 8 18:14:54 CET 2010 Tobias Rautenkranz * sbcl-bundle requires posix & unix Thu Feb 4 16:11:29 CET 2010 Tobias Rautenkranz * Test building libclsmoke. Wed Feb 3 17:20:56 CET 2010 Tobias Rautenkranz * Fix compiling libclsmoke with asserts enabled. smoke_get_class was not declared in this scope Reported by: Elliott Slaughter Wed Feb 3 07:44:09 CET 2010 Tobias Rautenkranz * Add missing :sb-posix dependency. Sat Jan 30 15:40:08 CET 2010 Tobias Rautenkranz * Do not warn on missing parent class. Tue Jan 26 17:26:09 CET 2010 Tobias Rautenkranz * Fix for r1077826. Not instantiable parent classes are external. (QAbstractPrintDialog) Mon Jan 25 19:47:00 CET 2010 Tobias Rautenkranz * Check enum type on overload resolution Mon Jan 25 19:46:41 CET 2010 Tobias Rautenkranz * single-float conversion Mon Jan 25 19:41:22 CET 2010 Tobias Rautenkranz * Add :arg3 for make-instance SMOKE-CLASS. Sat Jan 23 20:45:41 CET 2010 Tobias Rautenkranz * class & type size (and some more exports) Sun Jan 17 22:04:08 CET 2010 Tobias Rautenkranz * Fix class-map image loading and use the new static smoke methods. indClass() and isDerivedFrom() are now static (r1076132 and also in KDE 4.4). Sun Jan 10 18:31:42 CET 2010 Tobias Rautenkranz * Fix overload resolution when a lisp smoke module is not loaded. Sun Jan 10 18:30:48 CET 2010 Tobias Rautenkranz * Auto-recompile when the smoke module has changed. Sun Jan 10 09:49:36 CET 2010 Tobias Rautenkranz * Support modular smoke & cleanup. Sun Dec 13 13:43:58 CET 2009 Tobias Rautenkranz * Support ASDF instead of Mudballs. Sun Dec 13 11:17:08 CET 2009 Tobias Rautenkranz * Update to the new Smoke ABI (v.3) Fri Nov 6 20:27:56 CET 2009 Tobias Rautenkranz * Explicitly use old ABI (pre r1045709) Wed Sep 9 21:25:37 CEST 2009 Tobias Rautenkranz * Template types are no longer t_class. Wed Sep 9 15:22:32 CEST 2009 Tobias Rautenkranz * 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 * 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 * Fix overload resolution using types and test caching the overload resolution. Sun Aug 30 16:12:44 CEST 2009 Tobias Rautenkranz * Allow deriving from multiple C++ classes. Sun Aug 30 15:51:40 CEST 2009 Tobias Rautenkranz * 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 * 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 * Cleanup C++ to Lisp translation Fri Jul 24 15:32:23 CEST 2009 Tobias Rautenkranz * Fix conversion sequence from QByteArray to const char*. Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz * 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 * Speedup overload resolution and some other stuff for faster C++ method calling. diff -rN -u old-smoke/TODO new-smoke/TODO --- old-smoke/TODO 2014-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/smoke.mbd 1970-01-01 01:00:00.000000000 +0100 @@ -1,79 +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")) - ("sb-optimize" (:for :sbcl) (:needs "overload-resolution")) - ("smoke" (:needs "smoke-c" "objects" "clos")) - ("object-map" (:needs "objects" :utils)) - ("class-map" (:needs "package")) - ("bindings" (:needs "package")) - ("cxx-method" (:needs "package")) - ("clos" (:needs "smoke-c" "cxx-method" "objects" "object-map" "class-map" "bindings")) - ("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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/CMakeLists.txt 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/bindings.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/class-map.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/clos.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/cxx-method.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 @@ -0,0 +1,50 @@ +#ifndef CL_SMOKE_H +#define CL_SMOKE_H + +#include + +#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); +} +} // 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-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 @@ -0,0 +1,240 @@ +#include "cl_smoke.h" +#include "smokebinding.h" + +#include +#include + +/** @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(destruct)); + else + return new Binding(reinterpret_cast(destruct), + reinterpret_cast(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(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-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 @@ -0,0 +1,105 @@ +#include "smokebinding.h" + +#include +#include + +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-11-19 23:11:53.000000000 +0100 @@ -0,0 +1,50 @@ +#ifndef SMOKEBINDING_H +#define SMOKEBINDING_H + +#include + +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-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/object-map.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/objects/class.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/objects/enum.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/objects/method.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/objects/stack.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/objects/type.lisp 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/overload-resolution.lisp 2014-11-19 23:11:53.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,153 +109,113 @@ '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 @@ -311,49 +232,69 @@ (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)) @@ -364,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**") @@ -385,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))) @@ -393,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)))))) @@ -415,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)) @@ -429,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) @@ -445,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)) @@ -462,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) @@ -488,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) @@ -510,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 @@ -546,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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/package.lisp 2014-11-19 23:11:53.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 2014-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/sb-optimize.lisp 2014-11-19 23:11:53.000000000 +0100 @@ -81,10 +81,79 @@ sequence args))) `(lambda (object ,@argument-names) (s-call ,(method-form method) - ;; FIXME only cast when needed. - (cast object - (find-class (quote ,(class-name - (find-smoke-class - (get-class 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-11-19 23:11:53.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-11-19 23:11:53.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 - -#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); -} - -/** 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); -} -} // 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-11-19 23:11:53.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-11-19 23:11:53.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 - -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(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-11-19 23:11:53.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 - -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-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.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 - -#include - -/** @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), - reinterpret_cast(destruct), - reinterpret_cast(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-11-19 23:11:53.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-11-19 23:11:52.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-11-19 23:11:53.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-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/smoke.lisp 2014-11-19 23:11:53.000000000 +0100 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2009 Tobias Rautenkranz +;;; Copyright (C) 2009, 2010 Tobias Rautenkranz ;;; ;;; 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-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/src/using-type.lisp 2014-11-19 23:11:53.000000000 +0100 @@ -13,7 +13,7 @@ `(,function-name ,@args)) (call-using-type (function-name &rest args) `(,function-name ,@args))) - ,@body)) + ,@body)) (defun typep-using-type (object-type type) "Returns true when OBJECT-TYPE is a subtype of TYPE, diff -rN -u old-smoke/test-bundle.sh new-smoke/test-bundle.sh --- old-smoke/test-bundle.sh 2014-11-19 23:11:53.000000000 +0100 +++ new-smoke/test-bundle.sh 2014-11-19 23:11:53.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-11-19 23:11:53.000000000 +0100 +++ new-smoke/test.lisp 2014-11-19 23:11:53.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)