Mon Jun 22 14:18:08 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Speedup overload resolution by calling less into C, more efficient finding of the viable methods

and various optimizations.

This breaks Clozure CL -- fix it later.

-

-find_package(Qt4)

-set(QT_DONT_USE_QTGUI true)

-include(${QT_USE_FILE})

-

-find_library(SMOKE_KDE_LIBRARY smokekde)

-include(FindPackageHandleStandardArgs)

-find_package_handle_standard_args(smokekde DEFAULT_MSG SMOKE_KDE_LIBRARY)

-

-## kde-hello-world

-if(SMOKE_KDE_LIBRARY)

- include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../src/smoke-c/")

-

- add_executable(kde-hello-world kde-hello-world.cpp ../src/smoke-c/csmokebinding.cpp)

- target_link_libraries(kde-hello-world ${SMOKE_KDE_LIBRARY})

-endif(SMOKE_KDE_LIBRARY)

-/*

- * Copyright 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

- *

- * Permission is hereby granted, free of charge, to any person

- * obtaining a copy of this software and associated documentation

- * files (the "Software"), to deal in the Software without

- * restriction, including without limitation the rights to use,

- * copy, modify, merge, publish, distribute, sublicense, and/or sell

- * copies of the Software, and to permit persons to whom the

- * Software is furnished to do so, subject to the following

- * conditions:

- *

- * The above copyright notice and this permission notice shall be

- * included in all copies or substantial portions of the Software.

- *

- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

- * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES

- * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

- * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT

- * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,

- * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING

- * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR

- * OTHER DEALINGS IN THE SOFTWARE.

- */

-

-/**

- * Hello world example using libsmoke-c.

- * Display an KDE Window. */

-

-#include <smoke/qt_smoke.h>

-#include <smoke/kde_smoke.h>

-

-#include "smoke-c.cpp"

-

-#include <iostream>

-

-using namespace std;

-using namespace cl_smoke;

-

-static void

-destructed(Binding* binding, Smoke::Index class_id,

- void* object)

-{

- cout << "destructed: " << binding->className(class_id) << endl;

-}

-

-/** No method dispatch in this example. */

-static int

-dispatch(Binding* binding, Smoke::Index method,

- void* object, Smoke::Stack args, int abstract)

-{

- return false;

-}

-

-int

-main(int argc, char** argv)

-{

- init_kde_Smoke(); // calls also init_qt_Smoke();

- smoke_binding kde = smoke_init(kde_Smoke, reinterpret_cast<void*>(&destructed),

- reinterpret_cast<void*>(&dispatch));

- smoke_binding qt = smoke_init(qt_Smoke, reinterpret_cast<void*>(&destructed),

- reinterpret_cast<void*>(&dispatch));

-

- Smoke::StackItem stack[5];

- Smoke::ModuleIndex m;

- Smoke::ModuleIndex c;

-

- // bytearray = new QByteArray("foo");

- {

- char str[] = "foo";

-

- smoke_find_class(&c, qt_Smoke, "QByteArray");

- smoke_find_method(&m, qt_Smoke, c.index, "QByteArray$");

-

- stack[1].s_class = str;

-

- smoke_call_method(qt_Smoke, m.index, NULL, stack);

- }

- void* bytearray = stack[0].s_class;

-

-

- // l10n = ki18n(bar);

- {

- char str[] = "hello world";

- smoke_find_class(&c, kde_Smoke, "QGlobalSpace");

- smoke_find_method(&m, kde_Smoke, c.index, "ki18n$");

-

- stack[1].s_class = str;

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

- void* l10n = stack[0].s_class;

-

- // about = KAboutData(bytearray, bytearray, l10n, bytearray);

- {

- smoke_find_class(&c, kde_Smoke, "KAboutData");

- smoke_find_method(&m, kde_Smoke, c.index, "KAboutData####");

-

- stack[1].s_class = bytearray;

- stack[2].s_class = bytearray;

- stack[3].s_class = l10n;

- stack[4].s_class = bytearray;

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

- void* about = stack[0].s_class;

-

-

- // KCmdLineArgs::init(argc, argv, about);

- {

- smoke_find_class(&c, kde_Smoke, "KCmdLineArgs");

- smoke_find_method(&m, kde_Smoke, c.index, "init$?#");

-

- stack[1].s_int = argc;

- stack[2].s_class = argv;

- stack[3].s_class = about;

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

-

- // app = new KApplication();

- void* app;

- {

- smoke_find_class(&c, kde_Smoke, "KApplication");

- smoke_find_method(&m, kde_Smoke, c.index, "KApplication");

-

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- app = stack[0].s_class;

-

- smoke_set_binding(c.smoke, kde, c.index, app);

- }

-

- {

- smoke_find_class(&c, kde_Smoke, "KGlobalSettings");

- smoke_find_method(&m, kde_Smoke, c.index, "Disable");

- smoke_call_method(kde_Smoke, m.index, NULL, stack);

- }

-

- // widget = new KXmlGuiWindow();

- // widget->setupGUI();

- // widget->show();

- // return app->exec();

- void* widget;

- {

- smoke_find_class(&c, kde_Smoke, "KXmlGuiWindow");

- smoke_find_method(&m, kde_Smoke, c.index, "KXmlGuiWindow");

-

- smoke_call_method(m.smoke, m.index, NULL, stack);

- widget = stack[0].s_class;

- smoke_set_binding(c.smoke, kde, c.index, widget);

-

- smoke_find_method(&m, c.smoke, c.index, "setupGUI");

- smoke_call_method(m.smoke, m.index, widget, stack);

-

- smoke_find_method(&m, c.smoke, c.index, "show");

- smoke_call_method(m.smoke, m.index, widget, stack);

-

- smoke_find_class(&c, kde_Smoke, "KApplication");

- smoke_find_method(&m, c.smoke, c.index, "exec");

- smoke_call_method(m.smoke, m.index, NULL, stack);

-

- return stack[0].s_int;

- }

-}

-add_subdirectory(examples)

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

+ (method-maps (make-smoke-array) :type smoke-array)

+ (method-names (make-smoke-array) :type smoke-array)

+ (types (make-smoke-array) :type smoke-array)

+

+ (inheritance-list (null-pointer) :type foreign-pointer)

+ (argument-list (null-pointer) :type foreign-pointer)

+ (ambiguous-method-list (null-pointer) :type foreign-pointer))

+ [_$_]

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

+

+(defun init-smoke-module (module)

+ (let ((smoke (smoke-module-pointer module)))

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

+ module)

+ (flet ((mk-array (array)

+ (make-smoke-array :pointer (cl-smoke-array smoke array)

+ :length (cl-smoke-array-size smoke array))))

+ (setf (smoke-module-classes module) (mk-array :classes)

+ (smoke-module-methods module) (mk-array :methods)

+ (smoke-module-method-maps module) (mk-array :method-maps)

+ (smoke-module-method-names module) (mk-array :method-names)

+ (smoke-module-types module) (mk-array :types)

+

+ (smoke-module-inheritance-list module)

+ (cl-smoke-array smoke :inheritance-list)

+

+ (smoke-module-argument-list module)

+ (cl-smoke-array smoke :argument-list)

+

+ (smoke-module-ambiguous-method-list module)

+ (cl-smoke-array smoke :ambiguous-method-list)))))

+

- (let ((value (gethash (pointer-address smoke)

+ (let ((value (gethash (pointer-address (smoke-module-pointer smoke))

- smoke (smoke-get-module-name smoke))

+ smoke (smoke-get-module-name (smoke-module-pointer smoke)))

- (setf (gethash (pointer-address smoke) *smoke-id-class-map*)

+ (setf (gethash (pointer-address (smoke-module-pointer smoke)) *smoke-id-class-map*)

- "Convert camelCase to lisp-style."

+ "C++ namespace separator"

- ((smoke :reader smoke-symbol :initarg :smoke-symbol

- :type symbol))

+ ((pointer :type smoke-standard-class))

-(defmethod smoke ((class cxx:class))

- (eval (smoke-symbol class)))

-

+(defmethod pointer ((class cxx:class))

+ (pointer (slot-value class 'pointer)))

- :id (id superclass)

- :smoke (get-smoke-variable-for-pointer (smoke superclass))

+ :pointer superclass

+ :smoke (smoke superclass)

- :id (id superclass)

- :smoke (get-smoke-variable-for-pointer (smoke superclass))

+ :pointer superclass

+ :smoke (smoke superclass)

- (declare (foreign-pointer smoke)

- (optimize (speed 3)))

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

- (add-id-class-map smoke)

+ (declare (optimize (speed 3)))

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

+ (add-id-class-map smoke)

- :id (id class)

+ :pointer [_$_]

+ (pointer class)

+ ;(mem-aref (smoke-array-pointer [_$_]

+ ; (smoke-module-classes

+ ; (smoke class)))

+ ; 'smoke-class

+ ; (id class))

+(declaim (inline smoke-class-of))

- (if (subtypep (class-of object) (find-class 'smoke-class))

+ (declare (optimize (speed 3)))

+ (if (typep object 'smoke-class)

- (declare (optimize (speed 3)))

+ (declare (dynamic-extent args)

+ (optimize (speed 3)))

- ((binding :pointer)

- (id smoke-index)

- (object-pointer :pointer))

- (declare (ignore binding id)

- (optimize (speed 3)))

+ ((object-pointer :pointer))

+ (declare (optimize (speed 3)))

+(declaim (inline argument-to-lisp))

+(defun argument-to-lisp (stack-item type)

+ ;; FIXME do not take ownership of stack allocated objects.

+ (type-to-lisp stack-item type))

+

- args

- (stack-to-args (cffi:inc-pointer stack

- (cffi:foreign-type-size 'smoke-stack-item))

+ (reverse args)

+ (stack-to-args (inc-pointer stack

+ (foreign-type-size 'smoke-stack-item))

- (append args (list

- (type-to-lisp (cffi:mem-ref stack 'smoke-stack-item)

- arg))))))

+ (push (argument-to-lisp (mem-ref stack

+ 'smoke-stack-item)

+ arg)

+ args))))

- (object :pointer)

+ (object-ptr :pointer)

- (let* ((method (make-instance 'smoke-method

- :id method

- :smoke (smoke-get-smoke binding))))

+ (let* ((method (make-smoke-method

+ :smoke (gethash (pointer-address (smoke-get-smoke binding))

+ *smoke-modules*)

+ :id method)))

+ (declare (function gf))

- (let ((object (get-object object)))

+ (let ((object (get-object object-ptr)))

+ ;; FIXME:

+ ;;(assert object

+ ;; (object)

+ ;; "No object for ~A to call ~A." object-ptr method)

- (put-returnvalue

- stack

- (apply gf object

- (stack-to-args

- (cffi:inc-pointer stack [_$_]

- (cffi:foreign-type-size

- 'smoke-stack-item))

- (get-first-argument method)))

- (return-type method)

- object)

- t)

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

+ ;; Restarts to prevent stack unwinding across the C++ stack.

+ (declare (stream stream))

+ (declare (stream stream))

- (get-object object))

+ (get-object object-ptr))

+ (declare (stream stream))

- (format stream "Try again calling ~A" [_$_]

+ (declare (stream stream))

+ (format stream "Try again calling ~A." [_$_]

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

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

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

- class)))

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

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

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

+ (declare (optimize (speed 3)))

- (set-binding object (binding (smoke (class-of object))))

+ (set-binding object)

- (let ((ret (make-instance class

- :pointer pointer)))

+ (declare (type smoke-standard-class class)

+ (optimize (speed 3)))

+ (let ((ret (make-instance class :pointer pointer)))

- #-clisp

+ (declare (type smoke-standard-object object)

+ (optimize (speed 3)))

+(declaim (inline remove-wrapper-object))

+ (declare (optimize (speed 3)))

-(declaim (optimize (debug 3)))

- :smoke ',smoke))

+ :smoke ,smoke))

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

+

- (unless (and (= (smoke-methods-size ,smoke)

- ,(smoke-methods-size (eval smoke)))

- (= (smoke-method-name-size ,smoke)

- ,(smoke-method-name-size (eval smoke)))

- (= (smoke-types-size ,smoke)

- ,(smoke-types-size (eval smoke)))

- (= (smoke-classes-size ,smoke)

- ,(smoke-classes-size (eval smoke))))

+ (unless (sizes= (,smoke)

+ smoke-module-methods

+ smoke-module-method-names

+ smoke-module-method-maps

+ smoke-module-classes

+ smoke-module-types)

- (smoke-get-module-name ,smoke)))))

+ (smoke-get-module-name (smoke-module-pointer ,smoke))))))

- (let ((method (make-instance 'smoke-method

- :id (abs id)

- :smoke (eval smoke))))

+ (let ((method (make-smoke-method

+ :smoke (eval smoke)

+ :id (abs id))))

-(declaim (inline ptr -address))

-(defun ptr-address (pointer)

- ;; CLISP returns NIL for a null pointer

- #+clisp

- (if pointer

- (pointer-address pointer)

- 0)

- #-clisp

- (pointer-address pointer))

-

- (gethash (ptr-address pointer) *object-map*))

+ (gethash (pointer-address pointer) *object-map*))

- (setf (gethash (ptr-address pointer) *object-map*)

+ (setf (gethash (pointer-address pointer) *object-map*)

+(declaim (inline has-pointer-p))

- (nth-value 1 (gethash (ptr-address pointer) *object-map*)))

+ (nth-value 1 (gethash (pointer-address pointer) *object-map*)))

- (remhash (ptr-address pointer) *object-map*))

+ (remhash (pointer-address pointer) *object-map*))

+ (declare (optimize (speed 3)))

- (remhash (ptr-address pointer) *object-map*))

+ (remhash (pointer-address pointer) *object-map*))

- function class pointer condition))

+ function class pointer condition)

+ #+sbcl (sb-debug:backtrace 10))

+ (declare (optimize (speed 3)))

-;;;

-;;; find-class

-;;; ensure-class

-;;; make-instance

-;;; class-name

-;;; class-slots

-;;; class-direct-subclasses

-;;; class-direct-superclasses

-;;; class-of

-;;; subclassp / subtypep

+(defclass smoke-class ()

+ ;; FXIME maybe change back to id

+ ((pointer :type foreign-pointer

+ :initarg :pointer

+ :reader pointer)

+ (smoke :type smoke-module

+ :initarg :smoke

+ :reader smoke))

+ (:documentation "A class"))

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

-(defclass smoke-class (smoke-symbol)

- ()

- (:documentation "A class"))

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

- (foreign-slot-value (smoke-get-class (smoke class) (id class))

+ (foreign-slot-value (pointer class)

+(define-compiler-macro class-slot-value (&whole form class slot-name)

+ (if (constantp slot-name)

+ `(foreign-slot-value (pointer ,class)

+ 'smoke-class ,slot-name)

+ form))

+

- (foreign-pointer smoke)

- :id 0

- (loop for id from 1 to (1- (the fixnum (smoke-classes-size smoke))) do

- (setf (slot-value class 'id) id)

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

+ (declare (optimize (speed 3)))

-(defmethod get-flag ((class smoke-class) flag)

- (boole boole-and (class-slot-value class 'flags)

- (foreign-enum-value 'smoke-class-flags flag)))

+(defun get-class-flag (class flag)

+ (declare (optimize (speed 3)))

+ (logand (class-slot-value class 'flags)

+ (the fixnum (foreign-enum-value 'smoke-class-flags flag))))

- (/= 0 (get-flag class :constructor)))

+ (/= 0 (get-class-flag class :constructor)))

- (/= 0 (get-flag class :virtual-destructor)))

+ (/= 0 (get-class-flag class :virtual-destructor)))

- (smoke-find-class c smoke name)

+ (smoke-find-class c (smoke-module-pointer smoke) name)

- (error (make-condition 'undefined-class :name name :smoke-name (smoke-get-module-name smoke)))

+ (error (make-condition 'undefined-class :name name :smoke-name (smoke-get-module-name (smoke-module-pointer smoke))))

- :id (foreign-slot-value c 'smoke-module-index 'index)

- :smoke (foreign-slot-value c 'smoke-module-index 'smoke))))

+ :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*))))

- (smoke-is-derived-from (smoke class) (id class)

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

- (let ((class-index (smoke-get-parent-index (smoke class) index)))

- (assert (< class-index (smoke-classes-size (smoke class))))

+ (let ((class-index (mem-aref (smoke-module-inheritance-list [_$_]

+ (smoke class))

+ 'smoke-index

+ index)))

+ (assert (<= class-index

+ (smoke-array-length

+ (smoke-module-classes (smoke class)))))

- (make-instance 'smoke-class

- :id class-index

- :smoke (smoke class))))

+ (make-smoke-class-from-id (smoke class)

+ class-index)))

-(defclass smoke-method (smoke-symbol)

- ()

- (:documentation "A C++ method"))

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

+(defstruct smoke-method

+ (id 0 :type smoke-index)

+ (smoke (make-smoke-module) :type smoke-module))

+

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

+(defun smoke-method-pointer (method)

+ (declare (optimize (speed 3)))

+ (mem-aref (smoke-array-pointer (smoke-module-methods

+ (smoke-method-smoke method)))

+ 'smoke-method

+ (smoke-method-id method)))

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

+ (if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method)))

+ (null-pointer-p (smoke-method-pointer smoke-method)))

+(defmethod smoke ((method smoke-method))

+ (smoke-module-pointer (smoke-method-smoke method)))

+

+(defmethod id ((method smoke-method))

+ (declare (optimize (speed 3)))

+ (smoke-method-id method))

+

-(defun valid-p (method)

- "Returns T when METHOD is valid and NIL otherwise."

- (/= 0 (id method)))

-

-(defun unambigous-p (method)

- "Returns T when METHOD is valid and not ambiguous."

- (< 0 (id method)))

-

-(defun ambiguous-p (method)

- "Returns T when METHOD is ambiguous and NIL otherwise."

- (> 0 (id method)))

-

-(defun make-smoke-method-munged (class munged-name-id)

- "Returns the method for the MUNGED-NAME-ID of SMOKE."

- (with-foreign-object (module 'smoke-module-index)

- (smoke-find-method-for-id module (smoke class) (id class) munged-name-id)

- (make-instance 'smoke-method

- :id (foreign-slot-value module 'smoke-module-index 'index)

- :smoke (foreign-slot-value module 'smoke-module-index 'smoke))))

-

- (smoke-find-method m (smoke class) (id class) name)

- (make-instance 'smoke-method

- :id (foreign-slot-value m 'smoke-module-index 'index)

- :smoke (foreign-slot-value m 'smoke-module-index 'smoke))))

+ (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)

+ (let ((smoke (foreign-slot-value m 'smoke-module-index 'smoke)))

+ (make-smoke-method

+ :smoke (if (null-pointer-p smoke)

+ (make-smoke-module)

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

+ :id (foreign-slot-value m 'smoke-module-index 'index)))))

-(defun make-smoke-method (class name)

+(defun make-smoke-method-from-name (class name)

- (smoke-find-method m (smoke class) (id class) name)

+ (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name)

- (loop as i = (smoke-ambiguous-method (smoke class)

- (- (foreign-slot-value m 'smoke-module-index 'index)))

- while (> i 0)

+ (loop as i = (mem-aref (smoke-module-ambiguous-method-list (smoke class))

+ 'smoke-index

+ (- (foreign-slot-value m 'smoke-module-index 'index)))

+ while (> i 0)

- (let ((m (make-instance 'smoke-method :id i :smoke (smoke class))))

- (format t " ~A ~A~%" (name m) (signature m))))

- (error "The method ~S of ~S is ambigious" name (name class)));;TODO

- (make-instance 'smoke-method

- :id (foreign-slot-value m 'smoke-module-index 'index)

- :smoke (foreign-slot-value m 'smoke-module-index 'smoke))))

+ (let ((m (make-smoke-method :smoke (smoke class) :id i)))

+ (format t " ~A ~A~%" (name m) (signature m))))

+ (error "The method ~S of ~S is ambigious" name (name class))) ;;TODO

+ (make-smoke-method

+ :smoke (gethash (pointer-address

+ (foreign-slot-value m 'smoke-module-index 'smoke))

+ *smoke-modules*)

+ :id (foreign-slot-value m 'smoke-module-index 'index))))

- (cffi:foreign-pointer smoke)

- (let ((method (make-instance 'smoke-method

- :id 0

- :smoke smoke))

- (length (1- (the fixnum (smoke-methods-size smoke)))))

+ (let ((method (make-smoke-method :smoke smoke :id 0))

+ (length (smoke-array-length (smoke-module-methods smoke))))

- (setf (slot-value method 'id) id)

+ (setf (smoke-method-id method) id)

- (foreign-slot-value (smoke-get-method (smoke method) (id method))

+ (foreign-slot-value (smoke-method-pointer method)

+(define-compiler-macro method-slot-value (&whole form method slot-name)

+ "Optimize constant slot-names."

+ ;; declaring the function inline calls the compiler macro of

+ ;; foreign-slot-value with 'SLOT-NAME instead of its value an thus

+ ;; has no effect; thus the compiler macro.

+ (if (constantp slot-name)

+ `(foreign-slot-value (smoke-method-pointer ,method)

+ 'smoke-method ,slot-name)

+ form))

+ [_$_]

+

- (smoke-get-method-name (smoke method)

- (method-slot-value method 'name)))

+ (mem-aref (smoke-array-pointer (smoke-module-method-names

+ (smoke-method-smoke method)))

+ :string

+ (method-slot-value method 'name)))

- :smoke (smoke method)))

+ :smoke (smoke-method-smoke method)))

-(defmethod get-flag ((method smoke-method) flag)

+(defun get-method-flag (method flag)

+(define-compiler-macro get-method-flag (&whole form method flag)

+ (if (constantp flag)

+ `(logand (method-slot-value ,method 'flags)

+ ;; Resolve flag value at compile time

+ ,(foreign-enum-value 'smoke-method-flags flag)) [_$_]

+ form))

+

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

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

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

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

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

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

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

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

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

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

+

+(defun valid-p (method)

+ "Returns T when METHOD is valid and NIL otherwise."

+ (/= 0 (smoke-method-id method)))

- (< 0 (id method)))

+ (< 0 (smoke-method-id method)))

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

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

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

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

- (make-instance 'smoke-class

- :id (method-slot-value method 'class)

- :smoke (smoke method)))

-

- [_$_]

+ (make-smoke-class-from-id

+ (smoke-method-smoke method)

+ (method-slot-value method 'class)))

- (smoke-get-argument (smoke argument) (slot-value argument 'id)))

+ (declare (optimize (speed 3)))

+ (mem-aref (smoke-module-argument-list (smoke argument))

+ 'smoke-index

+ (call-next-method)))

- (= 0 (smoke-get-argument (smoke argument) (1+ (slot-value argument 'id)))))

+ (= 0 (mem-aref (smoke-module-argument-list (smoke argument))

+ 'smoke-index

+ (1+ (slot-value argument 'id)))))

+ (declare (optimize (speed 3)))

- :smoke (smoke method)))

+ :smoke (smoke-method-smoke method)))

- :smoke (smoke method)))

+ :smoke (smoke-method-smoke method)))

-

-(defclass smoke-symbol ()

- ((id :reader id :initarg :id

- :type smoke-index

- :documentation "The objects index.")

- (smoke :reader smoke :initarg :smoke

- :initform (null-pointer)

- :documentation "Pointer to the Smoke module."))

- (:documentation "A method or class in a Smoke module."))

-

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

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

- (call-next-method)

- (print-unreadable-object (smoke-symbol stream :type t)

- (princ (name smoke-symbol) stream))))

-

-(defgeneric name (smoke-symbol)

- (:documentation "Returns the name of SMOKE-SYMBOL."))

-

-(defgeneric get-struct-slot-value (smoke-symbol slot-name)

- (:documentation "Returns the slot value of SLOT-NAME of

-the SMOKE-SYMBOLs struct."))

+ [_$_]

+(declaim (inline id))

+ (declare (optimize (speed 3)))

- (incf-pointer (top stack) (foreign-type-size 'smoke-stack-item)))

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

+ form))

+ [_$_]

+ (declare (type (smoke-index 0) type-id)

+ (type call-stack stack)

+ (optimize (speed 3)))

+ (declare (optimize (speed 3)))

+ (declare (optimize (speed 3)))

+ (declare (optimize (speed 3)))

- (let ((object (object-to-lisp (foreign-slot-value stack-item

- 'smoke-stack-item

- 'class)

- type)))

- object))

+ (object-to-lisp (foreign-slot-value stack-item

+ 'smoke-stack-item

+ 'class)

+ type))

+ (declare (optimize (speed 3)))

-(defclass smoke-type (smoke-symbol)

- ()

+(declaim (inline smoke))

+

+(defclass smoke-type ()

+ ((id :reader id :initarg :id

+ :type smoke-index

+ :documentation "The objects index.")

+ (smoke :reader smoke :initarg :smoke

+ :type smoke-module

+ :documentation "Pointer to the Smoke module."))

-(defclass smoke-lazy-type (smoke::smoke-type)

- ((id :reader smoke::id

- :initarg :id)

- (smoke :initarg :smoke

- :reader smoke-symbol)))

+(defmethod print-object ((type smoke-type) stream)

+ (if (or (<= (id type) 0)

+ (null-pointer-p (smoke-module-pointer (smoke type))))

+ (call-next-method)

+ (print-unreadable-object (type stream :type t)

+ (princ (name type) stream))))

-(defmethod smoke::smoke ((type smoke-lazy-type))

- (eval (smoke-symbol type)))

+(defclass smoke-lazy-type (smoke-type)

+ ())

- (foreign-slot-value (smoke-get-type (smoke type) (id type))

+ (foreign-slot-value (mem-aref (smoke-array-pointer

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

+ 'smoke-type

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

+(define-compiler-macro type-slot-value (&whole form type slot-name)

+ (if (constantp slot-name)

+ `(foreign-slot-value (mem-aref (smoke-array-pointer

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

+ 'smoke-type

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

+ 'smoke-type ,slot-name)

+ form))

+ [_$_]

+

- :id (smoke-find-type smoke name)

+ :id (smoke-find-type (smoke-module-pointer smoke) name)

+ (declare (optimize (speed 3)))

-(defgeneric get-flag (object flag)

- (:documentation "Returns the value for FLAG of OBJECT."))

-

-(defmethod get-flag ((type smoke-type) flag)

+(defun get-type-flag (type flag)

+ (declare (optimize (speed 3)))

- #xF0 ;; = ! 0x0F

- (foreign-enum-value 'smoke-type-flags flag)))

+ #xF0 ;; = !0x0F

+ (the fixnum (foreign-enum-value 'smoke-type-flags flag))))

-(defun get-allocation-flag (type)

- (logand (type-slot-value type 'flags)

- #x30))

+(define-compiler-macro get-type-flag (&whole form type flag)

+ (if (constantp flag)

+ `(logand (type-slot-value ,type 'flags)

+ #xF0

+ ,(foreign-enum-value 'smoke-type-flags flag))

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

+ ;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30)

+ `(= ,(foreign-enum-value 'smoke-type-flags flag)

+ (logand #x30

+ (type-slot-value ,type 'flags))))

+(declaim (inline stack-p))

- (= (get-allocation-flag type) (get-flag type :stack)))

+ (allocation-flag-p type :stack))

- (= (get-allocation-flag type) (get-flag type :reference)))

+ (allocation-flag-p type :reference))

- (= (get-allocation-flag type) (get-flag type :pointer)))

+ (allocation-flag-p type :pointer))

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

+ (/= 0 (get-type-flag type :const))))

- (logand (type-slot-value type 'flags)

- (foreign-enum-value 'smoke-type-flags :type-id)))

+ (declare (smoke-type type)

+ (optimize (speed 3) (safety 0)))

+ (logand (the (c-integer :unsigned-short) (type-slot-value type 'flags))

+ #.(foreign-enum-value 'smoke-type-flags :type-id)))

- (= 0 (mem-ref (smoke-get-type (smoke type) (id type))

+ (= 0 (mem-ref (mem-aref (smoke-array-pointer

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

+ 'smoke-type

+ (id type))

- (make-instance 'smoke-class

- :id (type-slot-value type 'class)

- :smoke (smoke type)))

-

-

-;; FIXME why macro?

-(defmacro smoke-type-p (type smoke type-name)

- (let ((t2 (smoke-find-type smoke type-name)))

- `(and (= (id ,type) ,(id t2))

- (pointer-eq (smoke ,type) ,(smoke t2)))))

+ (make-smoke-class-from-id

+ (smoke type)

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

-(defun mung-char-p (character)

- "Returns true when CHARACTER is used for munging and false otherwise."

- (declare (character character))

- (case character

- ((#\$ #\? #\#) t)))

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

-(defun binary-search-method-names (name smoke start end)

- "Returns the index of NAME for the Smoke module SMOKE and 0 when

-NAME is not found."

- ;; FIXME search methods instead of methodMaps, since we are not

- ;; interrested in the munging.

- (declare ((smoke-index 1) start end)

- (string name)

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

- (if (> start end)

- 0

- (let* ((index (floor (+ end start) 2))

- (method-name (smoke-get-method-name smoke index))

- (diff (string/= method-name name)))

- (if diff

- (if (and (>= diff (length name))

- (mung-char-p (char method-name diff)))

- index

- (if (and (< diff (length name))

- (or (>= diff (length method-name))

- (char< (char method-name diff) (char name diff))))

- (binary-search-method-names name smoke (1+ index) end)

- (binary-search-method-names name smoke start (1- index))))

- index))))

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

-(defun method-name= (name munged)

- "Returns true when the name of the munged method name MUNGED is NAME."

- (let ((diff (string/= name munged)))

- (not (and diff

- (or (< diff (length name))

- (not (mung-char-p (char munged diff))))))))

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

-(defun munged-method-argument-count (munged-name)

- "Returns the number of arguments the method MUNGED-NAME uses."

- (- (1- (length munged-name))

- (position-if-not #'mung-char-p munged-name :from-end t)))

- [_$_]

-(defun method-argument-count= (name munged-name argument-count)

- (declare ((integer 1 #.call-arguments-limit) argument-count))

- (and (= (length munged-name) (+ (length name) argument-count))

- (mung-char-p (char munged-name (length name)))))

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

-(defun position-method-names (name argument-count smoke start end)

- "Returns a list of the method indices with name NAME

-that accept ARGUMENT-COUNT arguments."

- (declare (string name)

- ((smoke-index 1) start end)

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

+ (if (/= 0 id-cmp)

+ id-cmp

+ (cstring-cmp (smoke-method-name method)

+ name))))

+ [_$_]

+(defun first-unabigious-index (smoke index)

+ (declare (type smoke-index index)

- (let ((positions (loop for i from start to end

- while (method-name= name (smoke-get-method-name smoke i))

- when (method-argument-count= name (smoke-get-method-name smoke i)

- argument-count)

- collect i)))

- (loop for i from (1- start) downto 1

- while (method-name= name (smoke-get-method-name smoke i))

- do (when (method-argument-count= name (smoke-get-method-name smoke i)

- argument-count)

- (push i positions)))

- positions))

+ (if (>= index 0)

+ index

+ (mem-aref (smoke-module-ambiguous-method-list smoke)

+ 'smoke-index

+ (- index))))

-(defun smoke-modules (class)

- "Returns a list of super classes of CLASS; one or every smoke module

-that can be reached by super classes of CLASS. The returned super classes

-are as specific as possible."

- (let ((modules (list class)))

- (dolist (super-class (closer-mop:class-direct-superclasses class) modules)

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

- (not (eql super-class (find-class 'smoke-standard-object))))

- (dolist (c (smoke-modules super-class))

- (setf modules (adjoin c modules :key #'smoke)))))))

+(defun find-method-for-class (name class)

+ "Returns the index of a method with name NAME for class CLASS."

+ (declare (type foreign-pointer name)

+ (type smoke-class class)

+ (optimize (speed 3)))

+ (let* ((start 1) ;; 0 is "no method"

+ (class-id (id class))

+ (smoke (smoke class))

+ (end (smoke-array-length (smoke-module-method-maps smoke))))

+ (declare (type (smoke-index 0) start end))

+ (loop until (> start end) do

+ (let* ((index (the smoke-index (floor (+ end start) 2)))

+ (method (make-smoke-method [_$_]

+ :smoke smoke [_$_]

+ :id (the (smoke-index 0)

+ (first-unabigious-index

+ smoke

+ (foreign-slot-value

+ (mem-aref (smoke-array-pointer

+ (smoke-module-method-maps

+ smoke))

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

+ -1)

+(defmacro push-candidate-method (index name argument-count class methods)

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

+ (,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))

+ (,method (make-smoke-method

+ :smoke ,smoke

+ :id (first-unabigious-index

+ ,smoke

+ ,method-index))))

+ (declare (type smoke-index ,method-index))

+ (if (cstring/= ,name

+ (smoke-method-name ,method))

+ nil

+ (progn

+ (when (= (the smoke-index ,argument-count)

+ (the smoke-index (get-arguments-length ,method)))

+ (if (< ,method-index 0)

+ (let ((,ambig-index (- ,method-index)))

+ (declare (type smoke-index ,ambig-index))

+ (loop as ,i = (the smoke-index

+ (mem-aref (smoke-module-ambiguous-method-list

+ ,smoke)

+ '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))) [_$_]

+ t)))))

-(defun viable-functions (name argument-count class2)

+(defun all-smoke-superclasses (class)

+ "Returns a list of all superclasses 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)

- (let ((methods))

- (dolist (class (smoke-modules class2))

- (let ((index (binary-search-method-names

- name (smoke class) 1

- (smoke-method-name-size (smoke class)))))

- (loop for i in (position-method-names name argument-count (smoke class)

- index

- (smoke-method-name-size [_$_]

- (smoke class)))

- do [_$_]

- (let ((method (make-smoke-method-munged class i)))

- (if (unambigous-p method)

- (push method methods)

- (when (ambiguous-p method)

- (let ((index (- (id method))))

- (loop as i = (smoke-ambiguous-method (smoke method)

- index)

- while (> i 0) do

- (incf index)

- (push (make-instance 'smoke-method

- :smoke (smoke method)

- :id i)

- methods)))))))))

- methods))

- [_$_]

+ ;; FIXME make a lazy map-viable-functions to allow returning early,

+ ;; when an exact match is found.

+ (declare (optimize (speed 3)))

+ (with-foreign-string (name name)

+ (let ((methods)

+ (smoke (smoke class)))

+ (dolist (class (all-smoke-superclasses 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))))

+ methods)))

+ [_$_]

+ (declare (optimize (speed 3)))

- (< (rank conversion1) (rank conversion2))))

+ (< (the fixnum (rank conversion1))

+ (the fixnum (rank conversion2)))))

+ (declare (optimize (speed 3)))

+ ;; FIXME test for ambigious overload #'conversion=

-(defmacro string-case ((keyform) &body clauses)

- ;; FIXME this is horribly inefficient

- `(cond ,@(mapcar #'(lambda (clause)

- `((string= ,keyform ,(first clause))

- ,@(rest clause)))

- clauses)))

-

-(defmacro smoke-type-case ((keyform class) &body clauses)

- `(string-case ((name ,keyform))

- ,@(mapcar (curry #'apply

- #'(lambda (type-name lisp-type)

- `(,type-name (typep-using-type ,class (quote ,lisp-type)))))

- clauses)))

-

- (0 [_$_]

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

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

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

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

+ "Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."

- (assert (valid-p method)

- ()

- "No applicable method ~A() for ~A." name object-or-class)

+ (unless (valid-p method)

+ (error (make-condition 'no-applicable-cxx-method

+ :method name

+ :class object-or-class

+ :arguments arguments)))

- #:new-object

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

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

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

+};

+

-(defcfun smoke-classes-size smoke-index

- (smoke :pointer))

-

-(defcfun smoke-get-parent-index smoke-index

- (smoke :pointer)

- (class smoke-index))

-

- * @param binding Smoke binding of the object

- * @param class_id class id

- * @param object the object

+ * @param object pointer to the object

- *when the default method shall be invoked.

+ * when the default method shall be invoked.

-Binding::deleted(Smoke::Index classId, void *obj)

+Binding::deleted(Smoke::Index, void *object)

- destruct(this, classId, obj);

+ destruct(object);

- typedef void (*destructed)(Binding* binding, Smoke::Index class_id,

- void* object);

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

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

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

-(declaim (optimize (debug 3)))

-

-(defcfun smoke-get-method-map (:pointer smoke-method-map)

- (smoke :pointer)

- (index smoke-index))

-

-(defcfun smoke-find-method-for-id :void

- (m :pointer smoke-module-index)

- (smoke :pointer)

- (class-index smoke-index)

- (method-name smoke-index))

-

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

-

-(defcfun smoke-methods-size smoke-index

- (smoke :pointer))

-

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

- (smoke :pointer)

- (method smoke-index))

-

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

- (smoke :pointer)

- (method-index smoke-index))

-

-(defcfun smoke-method-name-size smoke-index

- (smoke :pointer))

-

-(defcfun smoke-call-method :void

- (smoke :pointer)

- (method smoke-index)

- (object :pointer)

- (stack smoke-stack))

-

-(defcfun smoke-get-argument smoke-index

- (smoke :pointer)

- (argument smoke-index))

-

-(defcfun smoke-ambiguous-method smoke-index

- (smoke :pointer)

- (ambiguous smoke-index))

- *

- * @example examples/kde-hello-world.cpp

- * This KDE example creates a KXmlGuiWindow.

- * Note that C++ is only used to make the example shorter

- * (by allowing to directly include smoke-c.cpp), but it could also

- * be implemented in C using \c dlsym.

- *

- * @image html doc/images/kde-hello-world.png "Screenshot"

- * @image latex doc/images/kde-hello-world.png "Screenshot" width=5cm

+

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

+}

+

-

-

-/** Gets the number of classes.

- *

- * @return the number of classes

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_classes_size(void* smoke)

-{

- return get_smoke(smoke)->numClasses;

-}

-

-/** Sets the binding for an newly constructed instance.

- * @param smoke the Smoke module

- * @param binding the Smoke binding

- * @param class_index the index of the instances class

- * @param object pointer to the class instance.

- */

-CL_SMOKE_EXPORT void

-smoke_set_binding(void* smoke, smoke_binding binding, Smoke::Index class_index, void* object)

-{

- Q_ASSERT(object != NULL);

- Q_ASSERT(binding != NULL);

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

-

- const Smoke::Class* klass = &get_smoke(smoke)->classes[class_index];[_^I_][_$_]

-

- Smoke::StackItem stack[2];

- stack[1].s_voidp = get_smoke_binding(binding);

-

- (*klass->classFn)(0, object, stack);

-}

-

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

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

-/** Returns the index of a base class.

- * @param smoke the Smoke module

- * @param class_index the class index

- * [_$_]

- * @return the index of a parent

- */

-CL_SMOKE_EXPORT Smoke::Index

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

-{

- Q_ASSERT(class_index >= 0);

-

- return get_smoke(smoke)->inheritanceList[class_index];

-}

-

-/** Gets the method map.

- * @param smoke the Smoke module

- * @param method the index of the method

- *

- * @return a pointer to the @c MethodMap entry.

- */

-CL_SMOKE_EXPORT const Smoke::MethodMap*

-smoke_get_method_map(void* smoke, Smoke::Index method)

-{

- Q_ASSERT(method >= 0 && method <= get_smoke(smoke)->numMethodMaps);

-

- return &get_smoke(smoke)->methodMaps[method];

-}

-

-/** Gets a methods name.

- * @param smoke the Smoke module

- * @param method_name the method name index

- *

- * @return the method name

- */

-CL_SMOKE_EXPORT const char*

-smoke_get_method_name(void* smoke, Smoke::Index method_name)

-{

- Q_ASSERT(method_name >= 0 && method_name <= get_smoke(smoke)->numMethodNames);

-

- return get_smoke(smoke)->methodNames[method_name];

-}

-

-/** Gets the number of method names.

- * @param smoke the Smoke module

- *

- * @return the number of method names

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_method_name_size(void *smoke)

-{

- return get_smoke(smoke)->numMethodNames;

-}

-

-/** Gets the number of methods.

- * @param smoke the Smoke module

- *

- * @return the number of methods

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_methods_size(void* smoke)

-{

- return get_smoke(smoke)->numMethods;

-}

-

-/** Gets a method.

- * @param smoke the smoke binding

- * @param method the index of the method

- *

- * @return a pointer to the method struct

- */

-CL_SMOKE_EXPORT const struct Smoke::Method*

-smoke_get_method(void* smoke, Smoke::Index method)

-{

- Q_ASSERT(method >= 0 && method <= smoke_methods_size(smoke));

-

- return &get_smoke(smoke)->methods[method];

-}

-

- m->index = smoke_get_method_map(m->smoke, m->index)->method;

-}

-

-/** Finds a method for a class and a munged name.

- * @param m pointer where the result is stored.

- * @param smoke the Smoke binding

- * @param class_index index of the class

- * @param method_name index of the munged method name

- */

-CL_SMOKE_EXPORT void

-smoke_find_method_for_id(Smoke::ModuleIndex* m, void* smoke,

- Smoke::Index class_index, Smoke::Index method_name)

-{

- *m = get_smoke(smoke)->findMethod((Smoke::ModuleIndex){get_smoke(smoke), class_index},

- (Smoke::ModuleIndex){get_smoke(smoke), method_name});

-

- if(m->index > 0)

- m->index = smoke_get_method_map(m->smoke, m->index)->method;

-}

-

-/** Gets the type index of an argument.

- * @param smoke the smoke binding

- * @param argument the argument index

- *

- * @return the type index

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_get_argument(void* smoke, Smoke::Index argument)

-{

- Q_ASSERT(argument >= 0);

-

- return get_smoke(smoke)->argumentList[argument];

-}

-

-/** Calls a method.

- * The methods return value is stored in the first element of the stack.

- * @param smoke the smoke binding

- * @param method the index of the method

- * @param object A pointer to the class instance, or NULL for static and constructor calls

- * @param stack The stack with the methods arguments.

- */

-CL_SMOKE_EXPORT void

-smoke_call_method(void* smoke, Smoke::Index method, void* object,

- Smoke::Stack stack)

-{

- Smoke::Method meth = *smoke_get_method(smoke, method);

- Q_ASSERT(!(meth.flags & Smoke::mf_internal));

- Q_ASSERT_X((NULL == object

- && (meth.flags & (Smoke::mf_static

- | Smoke::mf_enum

- | Smoke::mf_copyctor

- | Smoke::mf_ctor)))

- || object,

- __func__, "object is NULL");

- Q_ASSERT(meth.flags & Smoke::mf_ctor ? NULL == object : true);

- const Smoke::Class* klass = smoke_get_class(smoke, meth.classId);

-

- try

- {

- Q_ASSERT(klass->classFn != NULL);

- (*klass->classFn)(meth.method, object, stack);

- } [_$_]

- // This catch is mostly useless:

- // Qt / KDElibs do not use exceptions and since they are often built with -fno-exceptions

- // the catch will have no effect and the terminate handler is called instead.

- catch (const std::exception& e) [_$_]

- {

- qFatal(e.what());

- }

- catch (...)

- {

- qFatal("exception in C++ code.");

- }

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

-/** Gets the number of types.

- * @param smoke the Smoke module

- *

- * @return the number of types

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_types_size(void* smoke)

-{

- return get_smoke(smoke)->numTypes;

-}

-

-/** Gets a type.

- * @param smoke the Smoke module

- * @param type the index of the type

- *

- * @return a pointer to the type struct

- */

-CL_SMOKE_EXPORT const struct Smoke::Type*

-smoke_get_type(void* smoke, Smoke::Index type)

-{

- Q_ASSERT(type >= 0 && type <= smoke_types_size(smoke));

-

- return &get_smoke(smoke)->types[type];

-}

-

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

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

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

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

-/** Gets an ambiguous method.

- * @param smoke the Smoke module

- * @param ambiguous the index

- *

- * @return the index of a method

- */

-CL_SMOKE_EXPORT Smoke::Index

-smoke_ambiguous_method(void* smoke, Smoke::Index ambiguous)

-{

- Q_ASSERT(ambiguous >= 0);

-

- return get_smoke(smoke)->ambiguousMethodList[ambiguous];

-}

-

-(defcfun smoke-set-binding :void

- "Sets the binding for an newly constructed instance."

- (smoke :pointer)

- (smoke-binding smoke-binding)

- (class smoke-index)

- (object :pointer))

-

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

+

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

- "A type"

-

-(defcfun smoke-types-size smoke-index

- (smoke :pointer))

-

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

- (smoke :pointer)

- (type smoke-index))

-(defun s-call (method object &optional (args nil))

+(declaim (inline call-s-method) (optimize (debug 3)))

+(defun call-s-method (method object-pointer stack-pointer)

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

+ (foreign-slot-value (pointer (get-class method))

+ 'smoke-class

+ 'class-function)

+ ()

+ smoke-index (foreign-slot-value (smoke-method-pointer method)

+ 'smoke-method

+ 'method)

+ :pointer object-pointer

+ smoke-stack stack-pointer

+ :void))

+

+(defun s-call (method object-pointer &optional (args nil))

- (smoke-call-method (smoke method) (id method)

- object (pointer stack))

+ (call-s-method method object-pointer (pointer stack))

-(defun pointer-call (method object &optional (args nil))

+(defun pointer-call (method object-pointer &optional (args nil))

- (smoke-call-method (smoke method) (id method)

- object (pointer stack))

+ (call-s-method method object-pointer (pointer stack))

- (make-smoke-method class method-name)

+ (make-smoke-method-from-name class method-name)

- (make-smoke-method (make-smoke-class smoke class-name)

- method-name)

+ (make-smoke-method-from-name (make-smoke-class smoke class-name)

+ method-name)

- (smoke-call-method (smoke method) (id method)

- (null-pointer) (pointer stack))

+ (call-s-method method (null-pointer) (pointer stack))

-(defun new-object (binding class-name method-name &rest args)

- (let* ((smoke (smoke-get-smoke binding))

- (method (make-smoke-method (make-smoke-class smoke class-name)

- method-name))

- (pointer

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

- (object (instance-to-lisp pointer [_$_]

- (find-smoke-class (get-class (return-type method)))

- (return-type method))))

- (set-binding object (binding (smoke (class-of object))))

- (add-object object)

- object))

- [_$_]

-

+; (declare (optimize (speed 3)))

- (make-smoke-method class method-name)

+ (make-smoke-method-from-name class method-name)

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

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

-(defun set-binding (object binding)

- (smoke-set-binding (smoke (class-of object)) binding (id (class-of object)) (pointer object)))

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

-(defun init (smoke)

+(defun init (smoke module)

- (let ((binding (smoke-init smoke

- (callback destructed)

- (callback dispatch-method))))

- (setf (binding smoke) binding)

- binding))

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

- (setf (gethash (pointer-address (eval symbol)) pointer-symbol-map)

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

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

- :smoke (smoke method))

- methods)))

- smoke)))

- *smoke-id-class-map*)

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

- (when (search str (name method))

- (format t "~A::~A~%" (name (get-class method))

- (signature method))))

+ (when (search str (name method))

+ (princ (method-declaration method))

+ (terpri)))

- `(progn

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

+ (let ((smoke-module (intern "*SMOKE-MODULE*")))

+ `(progn

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

+ (use-foreign-library ,library))

+ (defcvar (,variable ,variable-name :read-only t) :pointer)

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

+ (length function-name)

+ function-name))

+ :void))

- (define-foreign-library ,library

- (:unix ,(format nil "~(~A~).so.2" library))

- (t (:default ,(format nil "~(~A~)" library))))

- (use-foreign-library ,library))

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

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

- function-name))

- :void))

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

- (,init-function)

- (init ,variable))

- (define-classes-and-gfs ,package ,variable)))

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

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

+ (,init-function)

+ (init ,variable ,smoke-module))

+ (define-classes-and-gfs ,package ,smoke-module))))

+;;; NOTE -using-type is disabled for now, since it is not used.

+

-false when it is not"; and :MAYBE when the relationship

-;could not be determined."

+false when it is not; and :MAYBE when the relationship

+could not be determined."

+ #+nil [_$_]

+ #+nil

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

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

-(mb:clean :smoke)

+;(mb:load :FiveAm)

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

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