darcs - smoke

repos / smoke / commitdiff

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

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.

diff -rN -u old-smoke/CMakeLists.txt new-smoke/CMakeLists.txt

--- old-smoke/CMakeLists.txt 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/CMakeLists.txt 2014-09-28 09:41:07.000000000 +0200

@@ -3,6 +3,5 @@

project(smoke)

add_subdirectory(src)

-add_subdirectory(examples)

include(UseDoxygen OPTIONAL)

diff -rN -u old-smoke/examples/CMakeLists.txt new-smoke/examples/CMakeLists.txt

--- old-smoke/examples/CMakeLists.txt 2014-09-28 09:41:07.000000000 +0200

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

@@ -1,16 +0,0 @@

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

diff -rN -u old-smoke/examples/kde-hello-world.cpp new-smoke/examples/kde-hello-world.cpp

--- old-smoke/examples/kde-hello-world.cpp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/examples/kde-hello-world.cpp 1970-01-01 01:00:00.000000000 +0100

@@ -1,164 +0,0 @@

-/*

- *

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

- }

diff -rN -u old-smoke/src/bindings.lisp new-smoke/src/bindings.lisp

--- old-smoke/src/bindings.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/bindings.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -20,3 +20,46 @@

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

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

binding)))

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

diff -rN -u old-smoke/src/class-map.lisp new-smoke/src/class-map.lisp

--- old-smoke/src/class-map.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/class-map.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -7,16 +7,16 @@

(defun id-class-map (smoke)

- (let ((value (gethash (pointer-address 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))

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

value))

(defun (setf id-class-map) (new-value smoke)

- (setf (gethash (pointer-address 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)

diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp

--- old-smoke/src/clos.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -92,7 +92,7 @@

(go-next camel-case)

(go-next default)))))

(namespace

- "Convert camelCase to lisp-style."

+ "C++ namespace separator"

(assert (eql #\: char))

(append-char #\.)

(go-next default))

@@ -117,13 +117,11 @@

(:documentation "A Smoke C++ class"))

(defclass cxx:class (smoke-standard-class)

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

- :type symbol))

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

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

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

- (eval (smoke-symbol class)))

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

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

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

@@ -162,8 +160,8 @@

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

(apply

#'call-next-method class

- :id (id superclass)

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

+ :pointer superclass

+ :smoke (smoke superclass)

:direct-superclasses direct-superclasses

args)))

@@ -183,8 +181,8 @@

(apply

#'call-next-method class

- :id (id superclass)

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

+ :pointer superclass

+ :smoke (smoke superclass)

:direct-superclasses direct-superclasses

args)))

@@ -197,10 +195,9 @@

(defun make-smoke-classes (package smoke)

"Construts a lisp class in PACKAGE for each one in the Smoke module SMOKE."

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

(map-classes

#'(lambda (class)

(unless (external-p class)

@@ -209,7 +206,13 @@

:direct-superclasses

(mapcar #'smoke-class-symbol

(smoke-class-direct-superclasses class))

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

@@ -222,9 +225,11 @@

(:metaclass closer-mop:funcallable-standard-class)

(:documentation "Smoke generic function."))

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

(defun smoke-class-of (object)

"Returns the class of OBJECT or OBJECT iff it alread is a class."

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

+ (declare (optimize (speed 3)))

+ (if (typep object 'smoke-class)

object

(class-of object)))

@@ -232,7 +237,8 @@

;;; ENSURE-METHOD is only called as needed.

(defmethod no-applicable-method ((gf smoke-gf) &rest args)

"Calls the smoke method."

- (declare (optimize (speed 3)))

+ (declare (dynamic-extent args)

+ (optimize (speed 3)))

(call-using-args (first args) (name gf) (rest args)))

(defmethod add-method :after ((gf cxx-method-generic-function) method)

@@ -248,28 +254,31 @@

(list ,@(rest lambda-list))))))))

(defcallback destructed :void

- ((binding :pointer)

- (id smoke-index)

- (object-pointer :pointer))

- (declare (ignore binding id)

- (optimize (speed 3)))

+ ((object-pointer :pointer))

+ (declare (optimize (speed 3)))

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

(when object

(cancel-finalization object)

(remove-object object-pointer)

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

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

(defun stack-to-args (stack arg &optional (args nil))

"Returns the arguments in STACK, where ARG is the type

of the first argument, as an list of Lisp objects."

(if (end-p arg)

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

(next arg)

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

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

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

@@ -304,40 +313,47 @@

(defcallback dispatch-method :boolean

((binding :pointer)

(method smoke-index)

- (object :pointer)

+ (object-ptr :pointer)

(stack smoke-stack)

(abstract :boolean))

(declare (optimize (speed 3)))

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

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

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

(if object

(progn

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

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)

@@ -346,6 +362,7 @@

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

@@ -356,10 +373,11 @@

(multiple-value-list (eval (read *query-io*))))

(put-returnvalue stack return-value

(return-type method)

- (get-object object))

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

@@ -368,7 +386,8 @@

(return-from dispatch-method (values)))

(retry ()

:report (lambda (stream)

- (format stream "Try again calling ~A"

+ (declare (stream stream))

+ (format stream "Try again calling ~A."

(method-declaration method))))))))

;;FIXME use CHANGE-CLASS instead?

@@ -378,10 +397,9 @@

()

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

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

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

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

;(id (class-of object)) (id (real-class class))))

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

- class)))

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

(defun upcast (object class)

@@ -389,7 +407,7 @@

()

"Can not upcast object ~A of class ~A to class ~A."

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

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

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

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

@@ -417,6 +435,7 @@

&key args &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)))

(assert (not (and (slot-boundp object 'pointer)

(not (null args))))

((slot-value object 'pointer) args)

@@ -424,31 +443,35 @@

(slot-value object 'pointer) args)

(unless (slot-boundp object 'pointer)

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

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

+ (set-binding object)

(take-ownership object)

(add-object object)))

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

- (let ((ret (make-instance class

- :pointer pointer)))

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

+ (optimize (speed 3)))

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

(when (stack-p type)

(take-ownership ret)

(add-object ret))

ret))

(defun keep-wrapper (object new-owner)

- #-clisp

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

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

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

(defun remove-wrapper-object (object owner)

(remove object (owned-objects owner)))

(defun transfer-ownership-to (object new-owner)

"Transfers the ownership of OBJECT to C++."

+ (declare (optimize (speed 3)))

(cancel-finalization object)

(if (virtual-destructor-p (class-of object))

(keep-wrapper object new-owner)

diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp

--- old-smoke/src/method.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/method.lisp 2014-09-28 09:41:08.000000000 +0200

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

(in-package :smoke)

-(declaim (optimize (debug 3)))

(defun constant-definition (package method smoke)

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

@@ -21,7 +20,7 @@

:value ,(enum-call method)

:type (make-instance 'smoke-lazy-type

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

- :smoke ',smoke))

+ :smoke ,smoke))

:test #'enum=)

symbol)))

@@ -72,20 +71,24 @@

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

(error "The smoke module ~A changed, you need to recompile the lisp file."

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

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

(defmacro define-classes-and-gfs (package smoke)

"Process the C++ methods of the Smoke module SMOKE.

@@ -132,9 +135,9 @@

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

(eval smoke))

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

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

- :id (abs id)

- :smoke (eval smoke))))

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

+ :smoke (eval smoke)

+ :id (abs id))))

(multiple-value-bind (definition export)

(static-method-definition

package

diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp

--- old-smoke/src/object-map.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -41,43 +41,36 @@

except object with a non virtual destuctor which had their ownership transfered

to C++.")

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

(declaim (inline get-object))

(defun get-object (pointer)

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

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

(declaim (inline (setf get-object)))

(defun (setf get-object) (value pointer)

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

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

value))

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

(defun has-pointer-p (pointer)

"Returns T when there is an object for POINTER in the map and NIL otherwise."

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

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

(defun remove-if-exists (pointer)

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

+ (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 (ptr-address pointer) *object-map*))

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

(defun report-finalize-error (condition function class pointer)

"Report the error CONDITION it the finalizer FUNCTION for the

object at POINTER of class CLASS."

(warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%"

- function class pointer condition))

+ function class pointer condition)

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

(defgeneric make-finalize (object)

(:documentation "Returns a function to be called when OBJECT is finalized."))

@@ -86,6 +79,7 @@

(let ((pointer (pointer object))

(class (class-of object)))

#'(lambda ()

+ (declare (optimize (speed 3)))

(handler-case (delete-pointer pointer class)

(error (condition)

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

diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp

--- old-smoke/src/objects/class.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/objects/class.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -1,56 +1,78 @@

(in-package #:smoke)

-;;;

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

(declaim (inline class-slot-value))

(defun class-slot-value (class slot-name)

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

+ (foreign-slot-value (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)

+ 'smoke-class ,slot-name)

+ form))

(defmethod name ((class smoke-class))

(class-slot-value class 'name))

(defun map-classes (function smoke)

"Applys FUNCTION to the classes of SMOKE."

(declare (function function)

- (foreign-pointer smoke)

(optimize (speed 3)))

(let ((class (make-instance 'smoke-class

- :id 0

:smoke smoke)))

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

(funcall function class))))

(defun external-p (class)

"Returns T when CLASS is external in its module; NIL otherwise."

+ (declare (optimize (speed 3)))

(class-slot-value class 'external))

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

(defmethod constructor-p ((class smoke-class))

"Returns T when CLASS has a constructor; NIL otherwise."

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

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

(defun virtual-destructor-p (class)

"Returns T when CLASS has a virtual destructor and NIL otherwise."

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

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

(define-condition undefined-class (cell-error)

((smoke-name :initarg :smoke-name

@@ -68,18 +90,20 @@

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

+ (smoke-find-class c (smoke-module-pointer smoke) 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)))

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

(return))

(supply (new-name)

:report "Supply a new class name"

:interactive read-new-value

(setf name new-name))))

(make-instance 'smoke-class

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

- :smoke (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*))))

(defun real-class (class)

"Returns the same class like CLASS, but such that EXTERNAL-P returns NIL."

@@ -101,21 +125,25 @@

T))

(defun derived-real-p (class base-class)

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

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

(smoke-add-superclass class nil (class-slot-value class 'parents)))

(defun smoke-add-superclass (class classes index)

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

(if (= 0 class-index)

classes

(smoke-add-superclass class (append classes

(list

- (make-instance 'smoke-class

- :id class-index

- :smoke (smoke class))))

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

+ class-index)))

(1+ index)))))

diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp

--- old-smoke/src/objects/method.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/objects/method.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -1,15 +1,32 @@

(in-package #:smoke)

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

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

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

(call-next-method)

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

(princ (method-declaration smoke-method) stream))))

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

(define-condition undefined-method (undefined-function)

((class-name :initarg :class-name

:initform nil))

@@ -19,42 +36,25 @@

(slot-value condition 'class-name))))

(:documentation "A undefined Smoke 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))))

(defun find-smoke-method (class name)

"Returns the method NAME of CLASS."

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

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

;smoke-find-method

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

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

"Returns the method NAME of CLASS.

Signals a undefined-method condition when no method was found.

Signals an error when the method is ambigious."

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

(do () (nil)

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

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

(restart-case

(if (null-pointer-p (foreign-slot-value m 'smoke-module-index 'smoke))

(error (make-condition 'undefined-method :name name :class-name (name class)))

@@ -64,29 +64,29 @@

:interactive read-new-value

(setf name new-name))))

(when (> 0 (foreign-slot-value m 'smoke-module-index 'index))

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

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

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

(defun map-methods (function smoke)

"Applys FUNCTION to the methods of SMOKE.

The method argument to function must not be modified."

(declare (function function)

- (cffi:foreign-pointer smoke)

(optimize (speed 3)))

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

(loop for id from 1 to length do

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

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

(funcall function method))))

(declaim (inline method-slot-value))

@@ -94,12 +94,25 @@

(declare (smoke-method method)

(symbol slot-name)

(optimize (speed 3)))

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

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

'smoke-method slot-name))

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

(defmethod name ((method smoke-method))

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

(defun signature (method)

"Returns the signature of METHOD."

@@ -122,7 +135,7 @@

"Returns the return type of METHOD."

(make-instance 'smoke-type

:id (method-slot-value method 'return-type)

- :smoke (smoke method)))

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

(defun method-declaration (method)

(format nil "~A~:[ void~; ~1:*~A~] ~A::~A"

@@ -131,61 +144,75 @@

(name (get-class method))

(signature method)))

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

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

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

(foreign-enum-value 'smoke-method-flags 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))

(defgeneric constructor-p (object)

(:documentation "Returns T when OBJECT is a constructor."))

(defmethod constructor-p ((method smoke-method))

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

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

(defun destructor-p (method)

"Returns T when METHOD is a destructor; NIL otherwise."

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

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

(defun static-p (method)

"Retruns T when METHOD is static and NIL otherwise."

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

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

(defun protected-p (method)

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

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

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

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

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

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

(defun ambigious-p (method)

"Returns T when METHOD is ambigious and NIL otherwise."

- (< 0 (id method)))

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

(defun enum-p (method)

"Returns T when METHOD is enum value and NIL otherwise."

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

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

(defun internal-p (method)

"Returns T when METHOD is internal and NIL otherwise."

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

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

(defmethod get-class ((method smoke-method))

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

(defclass smoke-argument (smoke-type)

()

(:documentation "A argument to a method"))

(defmethod id ((argument smoke-argument))

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

(defun last-p (argument)

"Returns T when ARGUMENT is the last argument and NIL otherwise."

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

(defun end-p (argument)

"Returns T when ARGUMENT is the after last element and NIL otherwise."

@@ -206,15 +233,16 @@

(defun get-first-argument (method)

"Returns the first argument of METHOD"

+ (declare (optimize (speed 3)))

(make-instance 'smoke-argument

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

- :smoke (smoke method)))

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

(defun get-argument (method index)

"Returns the type of METHODs argument with number INDEX."

(make-instance 'smoke-argument

:id (+ (method-slot-value method 'arguments) index)

- :smoke (smoke method)))

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

(defun build-argument-list (list argument)

diff -rN -u old-smoke/src/objects/object.lisp new-smoke/src/objects/object.lisp

--- old-smoke/src/objects/object.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/objects/object.lisp 2014-09-28 09:41:07.000000000 +0200

@@ -1,23 +1,3 @@

(in-package #:smoke)

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

diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp

--- old-smoke/src/objects/stack.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/objects/stack.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -20,6 +20,7 @@

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

@@ -27,7 +28,16 @@

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

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

(defclass smoke-standard-object ()

((pointer :reader pointer

@@ -43,6 +53,9 @@

(:documentation "The standard superclass for Smoke classes."))

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

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

+ (type call-stack stack)

+ (optimize (speed 3)))

(ecase type-id

(0 (push-stack stack value 'voidp))

(1 (push-stack stack value 'bool))

@@ -87,6 +100,7 @@

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

@@ -120,9 +134,11 @@

:type type))))

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

+ (declare (optimize (speed 3)))

(:documentation "Returns a clos instance for POINTER."))

(defun object-to-lisp (object type)

+ (declare (optimize (speed 3)))

(if (class-p type)

(let ((class (get-class type)))

(if (has-pointer-p object)

@@ -134,14 +150,14 @@

(defun class-to-lisp (stack-item type)

"Returns the Lisp representation for STACK-ITEM of type C++ class."

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

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

"Returns the Lisp representation of STACK-ITEM"

+ (declare (optimize (speed 3)))

(cond

((void-p type)

(values))

diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp

--- old-smoke/src/objects/type.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/objects/type.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -1,33 +1,55 @@

(in-package #:smoke)

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

(:documentation "A type"))

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

+ ())

(declaim (inline type-slot-value))

(defun type-slot-value (type slot-name)

(declare (smoke-type type)

(symbol slot-name)

(optimize (speed 3)))

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

'smoke-type slot-name))

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

(defun make-smoke-type (smoke name)

"Returns the type in the Smoke module SMOKE named NAME."

(make-instance 'smoke-type

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

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

:smoke smoke))

(defmethod name ((type smoke-type))

+ (declare (optimize (speed 3)))

(type-slot-value type 'name))

(defun smoke-type= (type1 type2)

@@ -36,34 +58,44 @@

(= (id type1)

(id type2))))

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

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

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

(defun stack-p (type)

"Returns T when TYPE is stored on the stack; NIL otherwise."

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

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

(defun reference-p (type)

"Returns T when TYPE is a reference ('type&'); NIL otherwise."

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

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

(defun pointer-p (type)

"Returns T when TYPE is a pointer ('type*'); NIL otherwise."

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

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

(defgeneric const-p (object)

(:method ((type smoke-type))

"Returns T when TYPE is const; NIL otherwise."

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

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

(defun class-p (type)

"Returns T when TYPE is a smoke class"

@@ -72,8 +104,10 @@

(defun type-id (type)

"Returns the ID of TYPE."

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

(defun void-p (type)

"Return T when TYPE is a void type (no value)."

@@ -81,7 +115,10 @@

;; For efficency 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 (smoke-get-type (smoke type) (id type))

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

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

+ 'smoke-type

+ (id type))

:char)))

@@ -93,13 +130,6 @@

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

(type)

"The type ~S is not a smoke class." (name 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)))

diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp

--- old-smoke/src/overload-resolution.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/overload-resolution.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -3,111 +3,188 @@

(in-package :smoke)

-(defun mung-char-p (character)

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

- (declare (character character))

- (case character

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

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

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

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

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

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

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

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

(optimize (speed 3)))

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

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

+ (if (>= index 0)

+ index

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

+ 'smoke-index

+ (- index))))

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

"Returns a list of methods named NAME that take ARGUMENT-COUNT methods."

;; 13.3.2

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

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

(defconstant +exact-match+ 0)

(defconstant +promotion+ 1)

@@ -164,9 +241,12 @@

;; 13.3.3.2 Ranking implicit conversion sequences

;; 4

(:method (conversion1 conversion2)

+ (declare (optimize (speed 3)))

(or (null conversion2)

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

+ (< (the fixnum (rank conversion1))

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

(:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))

+ (declare (optimize (speed 3)))

(if (eq (from conversion1) (from conversion2))

;; A->B < A->C <=> B subclass of C

(subtypep (to conversion1) (to conversion2))

@@ -267,6 +347,7 @@

(loop for method in viable-functions do

(multiple-value-bind (rank method-conversions)

(funcall get-sequence method objects)

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

(when (and rank (conversion< rank best-rank))

(setf best-rank rank)

(setf best-method method)

@@ -275,20 +356,6 @@

(return)))))

(values best-method conversions)))

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

(defvar *from-lisp-translations* (make-hash-table :test 'equal))

(defmacro define-from-lisp-translation (type-names lisp-type

@@ -318,9 +385,8 @@

(defun+using-type exact-match object (object type)

"Test for an exact match."

(case (type-id type)

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

(1 (object.typep 'boolean))

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

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

@@ -477,13 +543,16 @@

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

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

(if (static-p method)

(s-call method (null-pointer))

(s-call method (cast object-or-class (get-class method)))))

diff -rN -u old-smoke/src/package.lisp new-smoke/src/package.lisp

--- old-smoke/src/package.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/package.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -19,7 +19,6 @@

#:make-smoke-classes

#:eval-startup

- #:new-object

#:delete-object

#:smoke-call

#:call

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-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/cl_smoke.h 2014-09-28 09:41:07.000000000 +0200

@@ -13,11 +13,24 @@

#endif

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

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

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-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/class.lisp 2014-09-28 09:41:07.000000000 +0200

@@ -25,17 +25,10 @@

(smoke :pointer)

(name :string))

-(defcfun smoke-classes-size smoke-index

- (smoke :pointer))

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

(smoke :pointer)

(class smoke-index))

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

- (smoke :pointer)

- (class smoke-index))

(defcfun smoke-is-derived-from :boolean

(smoke :pointer)

(class 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-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/csmokebinding.cpp 2014-09-28 09:41:08.000000000 +0200

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

/** @typedef Binding::destructed

* Callback when a Smoke object is destructed.

- * @param binding Smoke binding of the object

- * @param class_id class id

- * @param object the object

+ * @param object pointer to the object

@@ -29,7 +27,7 @@

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

+ * when the default method shall be invoked.

/** Constructor.

@@ -50,9 +48,9 @@

/** Invoked when a Smoke object is destructed. */

void

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

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

{

- destruct(this, classId, obj);

+ destruct(object);

}

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

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-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/csmokebinding.h 2014-09-28 09:41:07.000000000 +0200

@@ -9,8 +9,7 @@

class Binding : public SmokeBinding

{

public:

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

- void* object);

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

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

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

@@ -18,7 +17,7 @@

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

virtual void

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

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

virtual bool

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

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-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/method.lisp 2014-09-28 09:41:07.000000000 +0200

@@ -1,7 +1,5 @@

(in-package #:smoke)

-(declaim (optimize (debug 3)))

(defcenum smoke-method-flags

"Method flags"

(:static #x01)

@@ -29,46 +27,9 @@

(name smoke-index)

(method smoke-index))

-(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-find-method :void

(m :pointer smoke-module-index)

(smoke :pointer)

(class smoke-index)

(method :string))

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

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-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/smoke-c.cpp 2014-09-28 09:41:07.000000000 +0200

@@ -7,15 +7,6 @@

/** @file

* @brief C wrapper the Smoke bindings.

- *

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

using namespace cl_smoke;

@@ -72,6 +63,68 @@

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

///////////////////////////

@@ -102,39 +155,6 @@

return m.index;

}

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

- Smoke::StackItem stack[2];

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

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

/** Gets a class

* @param smoke the smoke binding

* @param class_index the index of the class

@@ -144,7 +164,7 @@

CL_SMOKE_EXPORT const struct Smoke::Class*

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

{

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

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

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

}

@@ -166,88 +186,10 @@

get_smoke(smoke_base), base_index);

}

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

//////////////////////////////

/// Method

//////////////////////////////

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

/** Finds a method of a class.

* @param m pointer to write the result to

* @param smoke the smoke binding

@@ -261,110 +203,13 @@

*m = get_smoke(smoke)->findMethod(get_smoke(smoke)->className(class_index),

method_name);

if(m->index > 0)

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

}

///////////////////////////

/// Type

//////////////////////////

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

/** Gets the index of a type.

* @param smoke the Smoke module

* @param name the types name

@@ -388,24 +233,10 @@

CL_SMOKE_EXPORT void*

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

{

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

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

}

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

} // 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-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/smoke-c.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -57,15 +57,27 @@

(smoke :pointer)

(index smoke-index))

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

(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/type.lisp new-smoke/src/smoke-c/type.lisp

--- old-smoke/src/smoke-c/type.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke-c/type.lisp 2014-09-28 09:41:07.000000000 +0200

@@ -11,7 +11,6 @@

(:const #x40))

(defcstruct smoke-type

- "A type"

(name :string)

(class smoke-index)

(flags :unsigned-short))

@@ -19,10 +18,3 @@

(defcfun smoke-find-type smoke-index

(smoke :pointer)

(name :string))

-(defcfun smoke-types-size smoke-index

- (smoke :pointer))

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

- (smoke :pointer)

- (type smoke-index))

diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp

--- old-smoke/src/smoke.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -27,28 +27,40 @@

(in-package #:smoke)

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

(with-stack (stack args (arguments method) )

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

- object (pointer stack))

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

(type-to-lisp (pointer stack) (return-type method))))

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

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

(with-stack (stack args (arguments method) )

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

- object (pointer stack))

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

(foreign-slot-value (pointer stack) 'smoke-stack-item 'class)))

(defun smoke-call (class pointer method-name &optional (args nil))

(s-call

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

+ (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 (make-smoke-class smoke class-name)

- method-name)

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

+ method-name)

(null-pointer) args))

(defun enum-call (method)

@@ -61,56 +73,62 @@

;;

(assert (enum-p method))

(with-stack (stack nil nil)

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

- (null-pointer) (pointer stack))

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

(foreign-slot-value (pointer stack) 'smoke-stack-item 'long)))

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

(defun delete-pointer (pointer class)

"Destructs the object at POINTER of type CLASS.

Calls the destrutor and frees the memory."

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

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

(s-call

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

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

pointer))

(setf pointer (null-pointer)))

(defun delete-object (object)

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

(s-call

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

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

(pointer object)))

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

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

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

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

(let ((pointer-symbol-map (make-hash-table)))

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

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

- (setf (gethash (pointer-address (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."

@@ -141,46 +159,51 @@

(declare (string name)

(optimize (speed 3)))

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

methods))

(defun fgrep-methods (smoke str)

(map-methods #'(lambda (method)

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

smoke))

(defmacro define-smoke-module (package library

(variable variable-name)

(init-function function-name))

"Define a Smoke module."

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

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

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

(defun fgrep-classes (smoke str)

diff -rN -u old-smoke/src/using-type.lisp new-smoke/src/using-type.lisp

--- old-smoke/src/using-type.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/src/using-type.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -1,3 +1,5 @@

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

(in-package :smoke)

(defmacro with-object-as-object (object &body body)

@@ -15,8 +17,8 @@

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

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

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

-;could not be determined."

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

+could not be determined."

(declare (values (member t nil :maybe)))

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

(subtypep object-type type)

@@ -55,6 +57,7 @@

(with-object-as-object ,object

(defun ,name ,lambda-list

,@body))

+ #+nil

(with-object-as-type ,object

(defun ,(symbolicate name '-using-type) ,lambda-list

,@body))))

@@ -69,6 +72,7 @@

`(function ,name)))

(defun ,name ,lambda-list

,@body))

+ #+nil

(macrolet ((call-using-types (function-name &rest args)

`(,(symbolicate function-name '-using-types)

,@args))

diff -rN -u old-smoke/test.lisp new-smoke/test.lisp

--- old-smoke/test.lisp 2014-09-28 09:41:07.000000000 +0200

+++ new-smoke/test.lisp 2014-09-28 09:41:08.000000000 +0200

@@ -1,5 +1,5 @@

-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

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

exit 0

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

@@ -21,7 +21,9 @@

system-name))

(load-sysdef-file :smoke)

-(mb:clean :smoke)

+;(mb:load :FiveAm)

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

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

(mb:test :smoke)

(sb-ext:quit)

Crece desde el pueblo el futuro / crece desde el pie

RSS