Sun Apr 5 17:36:29 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* initial import

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

+++ new-smoke/CMakeLists.txt 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,8 @@

+cmake_minimum_required(VERSION 2.6)

+

+project(smoke)

+

+add_subdirectory(src)

+add_subdirectory(examples)

+

+include(UseDoxygen OPTIONAL)

--- old-smoke/TODO 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/TODO 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,22 @@

+Methods:

+ * C++ overload resolution & argument promotion

+ => no more writing (make-instance 'qt:byte-array :args ("foo"))

+ * Test for null pointer in this and for references

+ * default arguments

+ * fetch name of arguments

+

+* const correctness

+

+* keyword arguments for make-instance

+

+* QApplication and KCmdLineArgs.init call exit() on e.g. "--help"

+

+Testsuite:

+ * Fix segfaults when lots of qt:applictions are created & deleted

+ * Test condition & restarts

+

+finalization:

+ * get rid of owned-p

+ * use QObject::deleteLater ?

+

+* Exceptions

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

+++ new-smoke/examples/CMakeLists.txt 2014-09-28 09:39:50.000000000 +0200

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

+

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

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

+++ new-smoke/examples/kde-hello-world.cpp 2014-09-28 09:39:50.000000000 +0200

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

+/*

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

+ }

+}

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

+++ new-smoke/smoke.mbd 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,69 @@

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

+

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

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

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

+(defpackage :sysdef.cmake

+ (:use :cl :sysdef)

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

+(in-package :sysdef.cmake)

+

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

+ ()

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

+

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

+ ())

+;;; end SYDDEF.CMAKE

+

+(in-package :sysdef-user)

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

+ (use-package :sysdef.cmake))

+

+(define-system :smoke ()

+ (:version 0 0 1)

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

+implement bindings using the various Smoke modules.")

+ (:author "Tobias Rautenkranz")

+ (:components

+ ("CMakeLists" cmake-file)

+ (:src module

+ (:needs "CMakeLists")

+ (:components

+ ("CMakeLists.txt" static-file)

+ "package"

+ ("translate" (:needs "package"))

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

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

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

+ ("bindings" (:needs "package"))

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

+ ("method" (:needs "clos"))

+ (:objects module

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

+ (:serial t)

+ (:components "object" "enum" "method" "class"

+ "type" "instance" "stack"))

+ (:smoke-c module

+ (:needs "package" "translate")

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

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

+

+ ;; Make release-action add this files

+ ("CMakeLists.txt" static-file)

+ ("csmokebinding.h" static-file)

+ ("csmokebinding.cpp" static-file)

+ ("smoke-c.cpp" static-file)

+

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

+ "libsmoke-c-util"))

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

+ ("stack" (:needs "class"))

+ ("method" (:needs "stack"))

+ ("type" (:needs "method"))))

+

+ (:utils module

+ (:needs "package")

+ (:components "get-value")))))

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

+ :trivial-garbage :bordeaux-threads))

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

+++ new-smoke/src/CMakeLists.txt 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1 @@

+add_subdirectory(smoke-c)

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

+++ new-smoke/src/bindings.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,17 @@

+(in-package :smoke)

+

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

+

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

+;; load additional modules while threads are running.

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

+

+(defun binding (smoke)

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

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

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

+

+(defun (setf binding) (binding smoke)

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

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

+ binding)))

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

+++ new-smoke/src/class-map.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,31 @@

+(in-package :smoke)

+

+(defvar *smoke-id-class-map*

+ (make-hash-table)

+ "Maps a Smoke module pointer - id pair to a class.")

+;; FIXME disallow adding a class when threads are running or add a lock.

+

+(defmacro id-class-map (smoke)

+ `(gethash (pointer-address ,smoke)

+ *smoke-id-class-map*))

+

+(defun add-id-class-map (smoke)

+ (unless (nth-value 1 (id-class-map smoke))

+ (setf (id-class-map smoke)

+ (make-hash-table))))

+

+(defun add-id (smoke-class class)

+ "Associates the CLOS class CLASS with SMOKE-CLASS."

+ (setf (gethash (id smoke-class)

+ (id-class-map (smoke smoke-class)))

+ class))

+

+(defun find-smoke-class (class)

+ "Returns the CLOS class for smoke-class CLASS."

+ (let* ((class (real-class class))

+ (ret (gethash (id class)

+ (id-class-map (smoke class)))))

+ (assert (not (null ret))

+ ()

+ "The class ~A was not found." (name class))

+ ret))

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

+++ new-smoke/src/clos-types.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,48 @@

+(in-package :smoke)

+

+(defclass cxx::number () ())

+

+(defclass cxx::rational (cxx::number) ())

+

+(defclass cxx::int (cxx::rational) ())

+(defclass cxx::short (cxx::rational) ())

+

+

+(defclass cxx::real (cxx::number) ())

+

+(defclass cxx::float (cxx::real) ())

+(defclass cxx::double (cxx::real) ())

+

+

+(defclass cxx::char () ())

+(defclass cxx::pointer ()

+ ((next)))

+(defclass cxx::const ()

+ ((next)))

+

+

+(defgeneric convert (from to))

+

+(defmethod convert (from to)

+ (values nil nil))

+

+(defun char->int (c)

+ (char-code c))

+

+(defmethod convert ((from character) (to cxx::int))

+ (values #'char->int 1))

+

+(defmethod convert (from (to cxx::const))

+ (call-next-method (const from) to))

+

+(defmethod convert ((from cxx::const) (to cxx::const))

+ (call-next-method (next from) (next to)))

+

+(defun float->int (f)

+ (round f))

+

+(defmethod convert ((from float) (to cxx::int))

+ (values #'float->int 1))

+

+(defmethod convert ((from string) (to cxx::char)))

+;(defmethod convert ((from string) (to qstring)))

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

+++ new-smoke/src/clos.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,403 @@

+(in-package #:smoke)

+

+(declaim (optimize (speed 0) (debug 3)))

+

+(declaim (inline lispify))

+(defun lispify (name &optional (package nil))

+ "Returns the interned symbol for name in Lisp style."

+ (declare (string name)

+ (optimize (speed 3)))

+ (if (null package)

+ (values (intern (cxx-to-lisp name)))

+ (values (intern (cxx-to-lisp name) package))))

+

+(defmacro define-string-transform (name documentation &body states)

+ "Defines a function to transform a string."

+ (let ((output (gensym))

+ (index (gensym))

+ (length (gensym)))

+ `(defun ,name (input)

+ ,documentation

+ (declare (simple-string input)

+ (optimize (speed 3)))

+ ;; At least on sbcl 1.0.25.debian CONCATENATE is faster

+ ;; than VECTOR-PUSH-EXTEND

+ (let ((,output "")

+ (,index 0)

+ (,length (length input))

+ (char #\Null))

+ (declare (base-char char))

+ (macrolet ((next-char ()

+ `(if (>= ,',index ,',length)

+ (return-from transform ,',output)

+ (progn

+ (setf char (aref input ,',index))

+ (incf ,',index))))

+ (go-next (tag)

+ `(progn (next-char)

+ (go ,tag)))

+ (append-char (char)

+ `(setf ,',output (concatenate 'string

+ ,',output

+ (string ,char)))))

+ (block transform

+ (tagbody

+ (next-char) ;; Get first char

+ ,@(reduce #'append

+ (mapcar #'(lambda (state)

+ (if (stringp (second state))

+ `(,(first state) . ,(cddr state))

+ state))

+ states)))))))))

+

+

+(define-string-transform lisp-to-cxx

+ "Converts LISP-STYLE to camelCase.

+Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not neccessarily return

+a string equal to SMOME-STRING."

+ (default

+ "Downcase, convert _ and dispatch."

+ (case char

+ (#\- (go-next camel-upcase))

+ (#\. (go-next namespace))

+ (t (append-char (char-downcase char))

+ (go-next default))))

+ (camel-upcase

+ "Convert camelCase to lisp-style."

+ (append-char char)

+ (go-next default))

+ (namespace

+ "Convert . to ::"

+ (append-char #\:)

+ (append-char #\:)

+ (go default)))

+

+

+

+

+(define-string-transform cxx-to-lisp

+ "Returns camelCase STRING in lisp-style."

+ (begin

+ "Strip leadind Q or K."

+ (case char

+ (#\K (go-next default))

+ (#\Q (go-next default))

+ (t (go default))))

+ (default

+ "Upcase, convert _ and dispatch."

+ (case char

+ (#\: (go-next namespace))

+ (#\_ (append-char #\-)

+ (go-next default))

+ (t (append-char (char-upcase char))

+ (if (lower-case-p char)

+ (go-next camel-case)

+ (go-next default)))))

+ (namespace

+ "Convert camelCase to lisp-style."

+ (assert (eql #\: char))

+ (append-char #\.)

+ (go-next default))

+ (camel-case

+ "Convert camelCase to lisp-style."

+ (if (upper-case-p char)

+ (progn

+ (append-char #\-)

+ (append-char char)

+ (go-next default))

+ (go default))))

+

+

+(defclass smoke-standard-object ()

+ ((pointer :reader pointer :initarg :pointer

+ :documentation "Pointer to the C++ object.")

+ (owned-p :accessor owned-p :initarg :owned-p

+ :initform t

+ :documentation "T when the object is owned by Lisp and

+NIL when C++ is the owner.")

+ (const-p :reader const-p :initarg :const-p

+ :initform nil

+ :documentation "T when the object is const and NIL otherwise."))

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

+

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

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

+ (princ (pointer object) stream)))

+

+(defclass smoke-standard-class (standard-class smoke-class)

+ ((enumerations :initform (make-hash-table)

+ :initarg :enumerations

+ :reader enumerations

+ :documentation "The enumerations of the class.

+Maps the type-id of the enumeration to a hash-table that

+maps an enum value to a symbol."))

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

+

+(defclass smoke-wrapper-class (smoke-standard-class)

+ ())

+

+(defclass cxx:class (smoke-wrapper-class)

+ ()

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

+

+

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

+ T)

+

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

+ T)

+

+(defmethod reinitialize-instance :around

+ ((class smoke-standard-class)

+ &rest args &key direct-superclasses &allow-other-keys)

+ (apply

+ #'call-next-method class

+ :direct-superclasses (or direct-superclasses

+ (list (find-class

+ 'smoke-standard-object))) args))

+

+(defmethod initialize-instance :around

+ ((class smoke-standard-class)

+ &rest args &key direct-superclasses &allow-other-keys)

+ "Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default STANDARD-OBJECT."

+ (apply

+ #'call-next-method class

+ :direct-superclasses (or direct-superclasses

+ (list (find-class 'smoke-standard-object)))

+ args))

+

+(defmethod reinitialize-instance :around

+ ((class smoke-wrapper-class)

+ &rest args &key direct-superclasses &allow-other-keys)

+ (assert (not (null direct-superclasses))

+ (direct-superclasses)

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

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

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

+ ((first direct-superclasses))

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

+ (apply

+ #'call-next-method class

+ :id (id superclass)

+ :smoke (smoke superclass)

+ :direct-superclasses direct-superclasses

+ args)))

+

+(defmethod initialize-instance :around

+ ((class smoke-wrapper-class)

+ &rest args &key direct-superclasses &allow-other-keys)

+ (assert (not (null direct-superclasses))

+ (direct-superclasses)

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

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

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

+ ((first direct-superclasses))

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

+ (apply

+ #'call-next-method class

+ :id (id superclass)

+ :smoke (smoke superclass)

+ :direct-superclasses direct-superclasses

+ args)))

+

+(defun smoke-class-symbol (class)

+ (if (external-p class)

+ (class-name (find-smoke-class class))

+ (lispify (name class))))

+

+

+

+

+(defun make-smoke-classes (smoke)

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

+ (declare (optimize (speed 3)))

+ (add-id-class-map smoke)

+ (map-classes

+ #'(lambda (class)

+ (unless (external-p class)

+ (add-id class

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

+ :direct-superclasses

+ (mapcar #'smoke-class-symbol

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

+ :id (id class)

+ :smoke (smoke class)

+ :metaclass 'smoke-standard-class))

+ (export (lispify (name class)))))

+ smoke))

+

+(defun generic-lambda-list (method)

+ "Returns the lisp lambda list for METHOD."

+ (if (static-p method)

+ '(class &rest args)

+ '(object &rest args)))

+

+(defclass smoke-gf (standard-generic-function smoke-method)

+ ()

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

+ (:documentation "Smoke generic function"))

+

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

+ object

+ (class-of object)))

+

+;;; To speed up the startup (MAKE-SMOKE-METHODS)

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

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

+ "Calls the smoke method."

+ (let ((method (find-method-using-args (smoke-class-of (first args))

+ (name gf) (rest args))))

+ (if (static-p method)

+ (s-call method (null-pointer) (rest args))

+ (s-call method (cast (first args) (get-class method)) (rest args)))))

+

+(defmethod add-method :after ((gf smoke-gf) method)

+ "Adds a method which calls the smoke method, to make call-next-method work."

+ (when (null (rest (closer-mop:generic-function-methods gf)))

+ (closer-mop:ensure-method gf

+ `(lambda (object &rest args)

+ (let ((method (find-method-using-args (smoke-class-of object)

+ (name ,gf)

+ args)))

+ (if (static-p method)

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

+ (s-call method (cast object (get-class method)) args)))))))

+

+(defcallback destructed :void

+ ((binding :pointer)

+ (id smoke-index)

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

+

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

+ (next arg)

+ (append args (list

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

+ arg))))))

+

+(defgeneric set-returnvalue (stack value type))

+(defmethod set-returnvalue (stack (value smoke-standard-object) type)

+ (assert (class-p type)

+ (type)

+ "The type ~A of the value ~A is not a class."

+ (name type) value)

+ (setf (foreign-slot-value stack 'smoke-stack-item 'class)

+ (pointer value))

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

+ (cancel-finalization value) ;; Fixme mark object as invalid or copy it

+ ;(remove-object (pointer value))

+ (remove-if-exists (pointer value));;FIXME!

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

+

+(defmethod set-returnvalue (stack (value integer) type)

+ (setf (foreign-slot-value stack 'smoke-stack-item 'int)

+ value))

+

+(defmethod set-returnvalue (stack (value (eql t)) type)

+ (setf (foreign-slot-value stack 'smoke-stack-item 'bool)

+ value))

+

+(defun put-returnvalue (stack value type)

+ (unless (void-p type)

+ (set-returnvalue stack value type)))

+

+(defcallback dispatch-method :boolean

+ ((binding :pointer)

+ (method smoke-index)

+ (object :pointer)

+ (stack smoke-stack)

+ (abstract :boolean))

+ (declare (optimize (speed 3)))

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

+ :id method

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

+ (let ((gf (symbol-function (lispify (name method) "CXX"))))

+ (if (null (closer-mop:generic-function-methods gf))

+ (progn

+ (when abstract

+ (error "Abstract method ~S called." (name method)))

+ nil)

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

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

+ t)

+ nil))))))

+

+;;FIXME use CHANGE-CLASS instead?

+(defun cast (object class)

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

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

+ ()

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

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

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

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

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

+ class)))

+

+

+(defun upcast (object class)

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

+ ()

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

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

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

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

+

+

+(defmethod convert-to-class (smoke-class (object smoke-standard-object))

+ (cast object smoke-class))

+

+(defun make-smoke-constructor (class args)

+ (find-method-using-args class

+ (name class)

+ args))

+

+(defun call-constructor (object args)

+ (pointer-call (make-smoke-constructor (class-of object)

+ args)

+ (null-pointer)

+ args))

+

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

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

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

+ (not (null args))))

+ ((slot-value object 'pointer) args)

+ "Pointer ~A bound and constructor argument :ARGS ~S supplied."

+ (slot-value object 'pointer) args)

+ (unless (slot-boundp object 'pointer)

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

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

+ (setf (slot-value object 'owned-p) t)

+ (add-object object)))

+

+

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

+ (let ((ret (make-instance class

+ :owned-p (stack-p type)

+ :pointer pointer)))

+; (when (stack-p type)

+; (add-object ret))

+; (set-binding ret (binding (smoke (class-of ret)))))

+ ret))

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

+++ new-smoke/src/marshall.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,152 @@

+(in-package :smoke)

+

+(declaim (optimize (debug 3)))

+

+(defmacro average (&rest args)

+ `(floor (+ ,@args) ,(length args)))

+

+

+(defun binary-find (lower upper < =)

+ (let ((mid (average lower upper)))

+ (if (= mid lower)

+ nil

+ (if (funcall = mid)

+ mid

+ (if (funcall < mid)

+ (binary-find lower mid < =)

+ (binary-find mid upper < =))))))

+

+(defun serach-method (smoke name)

+ (binary-find 1 (smoke-method-name-size smoke)

+ #'(lambda (index)

+ (string< name

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

+ #'(lambda (index)

+ (string= name

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

+

+(defun find-last (lower upper =)

+ (if (or (>= lower upper)

+ (not (funcall = (1+ lower))))

+ lower

+ (find-last (1+ lower) upper =)))

+

+

+(defun find-methods (smoke name)

+ (let* ((index (serach-method smoke name))

+ (= #'(lambda (index)

+ (string= name

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

+ :end2 (length name))))

+ (upper (find-last index (smoke-method-name-size smoke) =))

+ (methods nil))

+ (loop for i from index to upper do

+ (push (smoke-get-method-name smoke i)

+ methods))

+ methods))

+

+

+

+;(defmethod exact-match ((object singl-float) type))

+(defun type-equal (type type-name)

+ (equal (name type) type-name))

+

+(defun exact-match (object type)

+ (format t "~A ~A~%" object (name type))

+ (ctypecase object

+ (smoke-standard-object

+ (and (class-p type)

+ (derived-p (class-of object)

+ (get-class type))))

+ (double-float (type-equal type "double"))

+ (single-float (type-equal type "float"))

+ (integer (type-equal type "int"))

+ (string (or (type-equal type "const char*")

+ (type-equal type "const QString&")))

+ (character (type-equal type "char"))))

+

+(defun exact-match-p (arguments types)

+ (if (or (null arguments) (null types))

+ (and (null arguments)

+ (null types))

+ (if (not (exact-match (first arguments)

+ (first types)))

+ nil

+ (exact-match-p (rest arguments)

+ (rest types)))))

+

+(defun promotion-match (object type)

+ (ctypecase object

+ (character (type-equal type "int"))

+ (float (type-equal type "double"))

+ (boolean (type-equal type "int"))))

+

+(defun standard-conversion-match (object type)

+ (ctypecase object

+ (number (or (type-equal type "short")

+ (type-equal type "int")

+ (type-equal type "long")))))

+

+(defun constructor-match (object type)

+ (if (class-p type)

+ (let ((constructor (make-smoke-constructor (get-class type)

+ (mung-arg object))))

+ (exact-match object (get-first-argument constructor)))

+ nil))

+

+(defun find-ambiguous-method (predicate method)

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

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

+ index)

+ while (> i 0) do

+ (incf index)

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

+ :smoke (smoke method)

+ :id i)))

+ (when (funcall predicate ambiguous-method)

+ (return ambiguous-method))))))

+

+(defun find-method-using-args (class name arguments)

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

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

+ (concatenate 'string name

+ (munged-args arguments)))

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

+ :smoke (foreign-slot-value m

+ 'smoke-module-index

+ 'smoke)

+ :id (foreign-slot-value m

+ 'smoke-module-index

+ 'index))))

+ (when (< (id method) 0)

+ (setf method

+ (find-ambiguous-method #'(lambda (method)

+ (exact-match-p arguments (arguments method)))

+ method))

+ (assert (not (null method)) (method)

+ "No method ~A::~A for the arguments ~A"

+ (name class) name arguments))

+ method)))

+

+

+(defgeneric get-convert-function (to from))

+(defmethod get-convert-function ((to eql 'int) (from eql 'char)))

+(defmethod get-convert-function ((to cxx::int) (from string)))

+

+(get-convert-function 'int 'char)

+

+;'const int 'char:

+(get-convert-function 'int 'char)

+&& (convert-const-p 'char)

+

+;'int 'const char:

+(get-convert-function 'int 'char)

+&& (not (const-p 'char))

+

+

+(defclass int ()

+ ((const-p)))

+

+(defun get-convert-function (to from))

+

+

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

+++ new-smoke/src/method.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,143 @@

+(in-package :smoke)

+

+(declaim (optimize (debug 3)))

+

+(defun enum-class-symbol (enum-type)

+ (let ((class-name (name (get-class enum-type))))

+ (if (null class-name)

+ 'global-enum-class

+ (lispify class-name))))

+

+(defun constant-definition (method smoke)

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

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

+ (let ((symbol

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

+ "Qt")

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

+ "+"))

+ (lispify (concatenate 'string

+ (name (get-class method))

+ ".+"

+ (name method) "+")))))

+ (values

+ ; `(defconstant ,symbol

+ ; ,(enum-call method))

+ `(alexandria:define-constant ,symbol

+ (make-instance 'enum

+ :value ,(enum-call method)

+ :type (make-instance 'smoke-type

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

+ :smoke ,smoke))

+ :test #'enum=)

+ `(export (quote ,symbol)))))

+

+(defun static-method-symbol (method)

+ "Returns the lisp symbol for the static method METHOD."

+ (let ((class (get-class method)))

+ (lispify (concatenate 'string

+ (if (string= (name class)

+ "QGlobalSpace")

+ nil

+ (concatenate 'string

+ (name class)

+ "."))

+ (name method)))))

+

+(defun static-method-definition (method smoke)

+ "Returns an expression to define a function for the static METHOD.

+The second return value is the expression to export the function."

+ (let* ((class (get-class method))

+ (method-name (name method))

+ (name (lispify (concatenate 'string

+ (if (string= (name class)

+ "QGlobalSpace")

+ nil

+ (concatenate 'string

+ (name class)

+ "."))

+ (name method)))))

+ (values

+ `(defun ,name (&rest args)

+ (let ((method (find-method-using-args (make-instance 'smoke-class

+ :id ,(id class)

+ :smoke ,smoke)

+ ,method-name args)))

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

+ `(export (quote ,name)))))

+

+(defun hash-table-key-values (hash-table)

+ "Returns a list containing all key-value pairs as CONS of HASH-TABLE."

+ (let ((list))

+ (maphash #'(lambda (key value)

+ (push (cons key value) list))

+ hash-table)

+ list))

+

+(defun ensure-generic-methods (names-and-ids smoke)

+ "Ensures the generic functions in NAMES-AND-IDS for the Smoke module SMOKE."

+ (dolist (name-id names-and-ids)

+ (ensure-generic-function (first name-id)

+ :id (rest name-id)

+ :smoke smoke

+ :generic-function-class 'smoke-gf

+ :lambda-list '(object &rest args))

+

+ (export (first name-id) :CXX)))

+

+(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 (= (smoke-methods-size ,smoke)

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

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

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

+

+

+(defmacro define-methods (smoke)

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

+Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods

+and a function do define the generic methods a load-time."

+;;; symbol - id pairs are stored in the hash-tables to prevent the

+;;; mulitiple definiton of a function with the same name.

+ (let ((generics (make-hash-table))

+ (constants)

+ (functions)

+ (function-symbols (make-hash-table))

+ (exports))

+ (map-methods

+ #'(lambda (method)

+ (when (and (enum-p method)

+ ;; FIXME workaround for

+ ;; http://lists.kde.org/?l=kde-bindings&m=123464781307375

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

+ "KGlobalSettings")))

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

+ (push def

+ constants)

+ (push export exports)))

+ (when (and (not (destructor-p method))

+ (not (constructor-p method))

+ (not (enum-p method))

+ (not (eql nil (name method)))

+ (string/= (name method) "tr")) ;; we have a custom qt:tr funciton

+ (setf (gethash (lispify (name method) "CXX") generics)

+ (id method))

+ (when (static-p method)

+ (let ((function-symbol (static-method-symbol method)))

+ (unless (nth-value 1 (gethash function-symbol function-symbols))

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

+ (multiple-value-bind (def export) (static-method-definition method smoke)

+ (push def functions)

+ (push export exports)))))))

+ (eval smoke))

+ `(progn (check-recompile ,smoke)

+ ,@functions

+ (eval-when (:load-toplevel)

+ (ensure-generic-methods ',(hash-table-key-values generics) ,smoke)

+ (make-smoke-classes ,smoke)

+ )

+ ,@constants

+ ,@exports)))

+

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

+++ new-smoke/src/object-map.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,69 @@

+(in-package :smoke)

+

+(defvar *object-map*

+ #-cmucl (make-weak-hash-table :weakness :value)

+ #+cmucl (make-hash-table :weak-p :value)

+

+ "Maps eisp object to Smoke C++ object of a class.")

+

+;; FIXME This probably does not scale well. A per thread object-map

+;; or at least a read-write lock should be used.

+(defvar *object-map-mutex* (make-lock "object-map lock"))

+

+(defun get-object (pointer)

+ (with-lock-held (*object-map-mutex*)

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

+

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

+ (with-lock-held (*object-map-mutex*)

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

+ value)))

+

+

+(defun has-pointer-p (pointer)

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

+ (with-lock-held (*object-map-mutex*)

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

+

+

+(defgeneric make-finalize (object)

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

+

+(defmethod make-finalize (object)

+ (let ((pointer (pointer object))

+ (class (class-of object)))

+ #'(lambda ()

+ (handler-case (delete-pointer pointer class)

+ (condition (condition)

+ (format *debug-io* "error finalize ~A ~A~%" (name class)

+ condition))))))

+

+

+(defun add-object (object)

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

+ ()

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

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

+ (when (owned-p object)

+ (let ((finalizer (make-finalize object)))

+ (finalize object finalizer)))

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

+

+(defun remove-if-exists (pointer)

+ (with-lock-held (*object-map-mutex*)

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

+

+(defun remove-object (pointer)

+ (assert (has-pointer-p pointer)

+ (pointer)

+ "No object to remove for pointer ~A." pointer)

+ (with-lock-held (*object-map-mutex*)

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

+

+(defun print-garbage ()

+ (with-lock-held (*object-map-mutex*)

+ (maphash #'(lambda (pointer object)

+ (format t "~A of type: ~S~%"

+ (make-pointer pointer)

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

+ *object-map*)))

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

+++ new-smoke/src/objects/class.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,113 @@

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

+ ()

+ (:documentation "A class"))

+

+(defmethod get-struct-slot-value ((class smoke-class) slot-name)

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

+ 'smoke-class slot-name))

+

+(defmethod name ((class smoke-class))

+ (get-struct-slot-value class 'name))

+

+(defun map-classes (function smoke)

+ "Applys FUNCTION to the classes of SMOKE."

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

+ :id 0

+ :smoke smoke)))

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

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

+ (funcall function class))))

+

+(defun external-p (class)

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

+ (get-struct-slot-value class 'external))

+

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

+ (boole boole-and (get-struct-slot-value class 'flags)

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

+

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

+ ((smoke-name :initarg :smoke-name

+ :initform nil

+ :documentation "The name of the Smoke module"))

+ (:report (lambda (condition stream)

+ (format stream "No Smoke class named ~S in the Smoke module ~S."

+ (cell-error-name condition)

+ (slot-value condition 'smoke-name))))

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

+

+;smoke-find-class

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

+ "Returns the class named NAME of the smoke module SMOKE.

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

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

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

+

+(defun real-class (class)

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

+ (if (external-p class)

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

+ class))

+

+(defun class-id (module class)

+ "Returns the class id of CLASS for the Smoke module MODULE."

+ (if (eq (smoke class) module)

+ (id class)

+ (smoke-class-id module (name class))))

+

+;(defun smoke-subclassp (class base-class) TODO

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

+ "Returns T when CLASS is derived from BASE-CLASS and NIL when not."

+ (values

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

+ T))

+

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

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

+ (smoke base-class) (id base-class)))

+

+

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

+ (smoke-add-superclass class nil (get-struct-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))))

+ (if (= 0 class-index)

+ classes

+ (smoke-add-superclass class (append classes

+ (list

+ (make-instance 'smoke-class

+ :id class-index

+ :smoke (smoke class))))

+ (1+ index)))))

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

+++ new-smoke/src/objects/enum.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,66 @@

+(in-package :cxx-support)

+

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

+ (use-package :smoke :cxx-support))

+

+;;;

+;;; One could map enum-values to lisp symbols, store the type in the plist

+;;; an use thouse as enums, but C++ enums may have several symbols for

+;;; the same value and thus lisp symbols can not be used.

+

+(defclass enum ()

+ ((value :reader value

+ :initarg :value)

+ (type :reader enum-type

+ :initarg :type))

+ (:documentation "Holds the integer value and type of an C++ enum value."))

+

+(defmethod print-object ((enum enum) stream)

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

+ (format stream "~A ~A" (name (enum-type enum))

+ (value enum))))

+

+

+(defun check-enum-type (enum enum-type)

+ (assert (type= (enum-type enum)

+ enum-type)

+ (enum enum-type)

+ "The enums ~A is not of type ~A." enum (name enum-type)))

+

+(defun enum= (enum1 enum2)

+ "Returns true when ENUM1 and ENUM2 are equal and false otherwise."

+ (declare (enum enum1 enum2))

+ (assert (type= (enum-type enum1)

+ (enum-type enum2))

+ (enum1 enum2)

+ "The enums ~A and ~A have a different type." enum1 enum2)

+ (= (value enum1) (value enum2)))

+

+(defmacro enum-xcase (case keyform &body cases)

+ (let ((type (enum-type (eval (first (first cases))))))

+ (loop for case in cases do

+ (check-enum-type (eval (first case))

+ type)))

+ `(progn

+ ; (check-enum-type (enum-type ,keyform)

+ ; (enum-type ,(first (first cases))))

+ (,case (value ,keyform)

+ ,@(loop for case in cases

+ collect `(,(value (eval (first case)))

+ ,@(rest case))))))

+

+(defmacro enum-case (keyform &body cases)

+ `(enum-xcase case ,keyform ,@cases))

+

+(defmacro enum-ecase (keyform &body cases)

+ `(enum-xcase ecase ,keyform ,@cases))

+

+(defmacro enum-cases (keyform &body cases)

+ "Keyform returns a number; cases are enums."

+ `(case ,keyform

+ ,@(loop for case in cases

+ collect `(,(value (eval (first case)))

+ ,@(rest case)))))

+

+(defun enum-logand (&rest enums)

+ (apply #'logand (mapcar #'value enums)))

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

+++ new-smoke/src/objects/instance.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,7 @@

+(in-package #:smoke)

+

+(defclass object (smoke-class)

+ ((pointer :reader pointer :initarg :pointer

+ :initform (null-pointer)

+ :documentation "Pointer to the C++ object."))

+ (:documentation "A Smoke CPP object"))

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

+++ new-smoke/src/objects/method.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,311 @@

+(in-package #:smoke)

+(declaim (optimize (debug 3)))

+

+(defclass smoke-method (smoke-symbol)

+ ()

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

+

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

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

+ (call-next-method)

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

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

+

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

+ ((class-name :initarg :class-name

+ :initform nil))

+ (:report (lambda (condition stream)

+ (format stream "No Smoke method ~S for class ~S."

+ (cell-error-name condition)

+ (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 ambiguous-p (method)

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

+ (> 0 (id method)))

+

+;smoke-find-method

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

+ "Returns the method called NAME of CLASS.

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

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

+ (do () (nil)

+ (smoke-find-method m (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)))

+ (return))

+ (supply (new-name)

+ :report "Supply a new method name"

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

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

+

+(defun type-equal (type type-name)

+ "Returns true when TYPE is of the type named TYPE-NAME and false otherwise."

+ (equal (name type) type-name))

+

+(defun exact-match (object type)

+ "Returns true when the type of OBJECT is exactly the same as TYPE and

+false otherwise."

+ (ctypecase object

+ (smoke-standard-object

+ (and (class-p type)

+ (derived-p (class-of object)

+ (get-class type))))

+ (double-float (type-equal type "double"))

+ (single-float (type-equal type "float"))

+ (integer (type-equal type "int"))

+ ;; int is also enum

+ ;; FIXME remove magic number 12

+ ;;(= (type-id type) 12)))

+ (string (or (type-equal type "const char*")

+ (type-equal type "const QString&")))

+ (enum (type= (enum-type object)

+ type))

+ (sequence (type-equal type "const QStringList&"))

+ (character (type-equal type "char"))))

+

+(defun exact-match-p (arguments types)

+ "Returns true when all the type of ARGUMENTS is the same as the

+corresponing type of TYPES and the length of the ARGUMENTS and TYPES list

+is equal."

+ (if (or (null arguments) (null types))

+ (and (null arguments)

+ (null types))

+ (if (not (exact-match (first arguments)

+ (first types)))

+ nil

+ (exact-match-p (rest arguments)

+ (rest types)))))

+

+(defun mung-arg (argument)

+ "Returns the mung char for ARUGMENT."

+ ;; FIXME void* is #\$ but void[] is #\?

+ ;; FIXME Get rid of the mugging stuff and compute the applicable methods

+ ;; including argument promotion

+ (case argument

+ ((t nil) #\$) ;; Booleans

+ (otherwise

+ (ctypecase argument

+ (number #\$)

+ (string #\$)

+ (foreign-pointer #\?)

+ (sequence #\?)

+ (enum #\$)

+ (smoke-standard-object #\#)))))

+

+(defun munged-args (arguments &optional (string nil))

+ "Maps the type of every item of ARGUMENTS to a char;

+Returns the list of the chars."

+ (if (null arguments)

+ string

+ (munged-args (rest arguments)

+ (append string (list (mung-arg (first arguments)))))))

+

+(defun find-ambiguous-method (predicate method)

+ "Returns a method of the ambiguous method METHOD such that

+PREDICATE is true. NIL is returned when no matching method is found."

+ (assert (ambiguous-p method)

+ (method)

+ "The method is not ambiguous.")

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

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

+ index)

+ while (> i 0) do

+ (incf index)

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

+ :smoke (smoke method)

+ :id i)))

+ (when (funcall predicate ambiguous-method)

+ (return ambiguous-method))))))

+

+(defun find-method-using-args (class name arguments)

+ "Returns the method of class CLASS with the name NAME

+for the arguments ARGUMENTS."

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

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

+ (concatenate 'string name

+ (munged-args arguments)))

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

+ :smoke (foreign-slot-value m

+ 'smoke-module-index

+ 'smoke)

+ :id (foreign-slot-value m

+ 'smoke-module-index

+ 'index))))

+ (assert (valid-p method)

+ (method)

+ "No method ~A::~A for the arguments ~A" (name class) name arguments)

+ (when (ambiguous-p method)

+ (setf method

+ (find-ambiguous-method #'(lambda (method)

+ (exact-match-p arguments (arguments method)))

+ method))

+ (assert (not (null method)) (method)

+ "No method ~A::~A for the arguments ~A"

+ (name class) name arguments))

+ method)))

+

+

+(defun map-methods (function smoke)

+ "Applys FUNCTION to the methods of SMOKE.

+The method argument to function must not be modified."

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

+ :id 0

+ :smoke smoke)))

+ (loop for id from 1 to (1- (smoke-methods-size smoke)) do

+ (when (= (mod id (floor (smoke-methods-size smoke) 10)) 0)

+ (format t "[ ~A ]~%" (* 10

+ (floor (* 10 id)

+ (smoke-methods-size smoke)))))

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

+ (funcall function method))))

+

+(defmethod get-struct-slot-value ((method smoke-method) slot-name)

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

+ 'smoke-method slot-name))

+

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

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

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

+

+(defun signature (method)

+ "Returns the signature of METHOD."

+ (format nil "~A(~{~A~^, ~}) ~:[~;const~]"

+ (name method)

+ (mapcar #'name (arguments method))

+ (const-p method)))

+

+(defun access (method)

+ "Returns the access for METHOD. (public or protected)"

+ (if (protected-p method)

+ "protected"

+ "public"))

+

+(defun modifiers (method)

+ (format nil "~A~:[~; static~]" (access method)

+ (static-p method)))

+

+(defun return-type (method)

+ "Returns the return type of METHOD."

+ (make-instance 'smoke-type

+ :id (get-struct-slot-value method 'return-type)

+ :smoke (smoke method)))

+

+(defun method-declaration (method)

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

+ (modifiers method)

+ (name (return-type method))

+ (name (get-class method))

+ (signature method)))

+

+(defgeneric get-flag (object flag)

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

+

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

+ (logand (get-struct-slot-value method 'flags)

+ (foreign-enum-value 'smoke-method-flags flag)))

+

+(defgeneric constructor-p (object)

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

+

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

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

+

+(defun destructor-p (method)

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

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

+

+(defun static-p (method)

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

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

+

+(defun protected-p (method)

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

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

+

+(defun ambigious-p (method)

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

+ (< 0 (id method)))

+

+(defun enum-p (method)

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

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

+

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

+ (make-instance 'smoke-class

+ :id (get-struct-slot-value method 'class)

+ :smoke (smoke method)))

+

+

+

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

+

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

+

+(defun end-p (argument)

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

+ (= 0 (id argument)))

+

+(defun next (argument)

+ "Returns the argument following ARGUMENT."

+ (assert (not (end-p argument))

+ (argument)

+ "Access after end element")

+ (make-instance 'smoke-argument

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

+ :smoke (smoke argument)))

+

+(defun get-arguments-length (method)

+ "Returns the number of arguments for METHOD."

+ (get-struct-slot-value method 'num-args))

+

+(defun get-first-argument (method)

+ "Returns the first argument of METHOD"

+ (make-instance 'smoke-argument

+ :id (get-struct-slot-value method 'arguments)

+ :smoke (smoke method)))

+

+(defun get-argument (method index)

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

+ (make-instance 'smoke-argument

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

+ :smoke (smoke method)))

+

+

+(defun build-argument-list (list argument)

+ (if (end-p argument)

+ list

+ (build-argument-list (append list (list argument))

+ (next argument))))

+

+(defun arguments (method)

+ "Returns a list of the arguments of METHOD."

+ (build-argument-list nil (get-first-argument method)))

+

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

+++ new-smoke/src/objects/object.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,22 @@

+(in-package #:smoke)

+

+(defclass smoke-symbol ()

+ ((id :reader id :initarg :id

+ :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."))

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

+++ new-smoke/src/objects/stack.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,171 @@

+(in-package #:smoke)

+

+(declaim (optimize (debug 3)))

+(defclass call-stack ()

+ ((pointer :reader pointer :initarg :pointer

+ :initform (null-pointer)

+ :documentation "Pointer to the Smoke stack")

+ (top :accessor top :initarg :top

+ :initform (null-pointer)

+ :documentation "Pointer to push the next argument to.")

+ (cleanup-stack :accessor cleanup-stack

+ :initform nil

+ :documentation "Cleanup functions"))

+ (:documentation "Contains the argument passed to a Smoke method."))

+

+(defmethod size ((stack call-stack))

+ "Returns the size (number of arguments) of STACK."

+ (/

+ (- (pointer-address (top stack))

+ (pointer-address (pointer stack)))

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

+

+(defun make-call-stack (smoke-stack)

+ (make-instance 'call-stack

+ :pointer smoke-stack

+ :top (inc-pointer smoke-stack (foreign-type-size 'smoke-stack-item))))

+

+(defun push-stack (stack value type)

+ (setf (foreign-slot-value (top stack)

+ 'smoke-stack-item type) value)

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

+

+(defun push-cleanup (stack function)

+ "Adds the cleanup function FUNCTION to STACK"

+ (push function (cleanup-stack stack)))

+

+(defun push-stack2 (stack value type-id)

+ (ecase type-id

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

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

+ (2 (push-stack stack value 'char))

+ (3 (push-stack stack value 'uchar))

+ (4 (push-stack stack value 'short))

+ (5 (push-stack stack value 'ushort))

+ (6 (push-stack stack value 'int))

+ (7 (push-stack stack value 'uint))

+ (8 (push-stack stack value 'long))

+ (9 (push-stack stack value 'ulong))

+ (10 (push-stack stack value 'float))

+ (11 (push-stack stack value 'double))

+ (12 (push-stack stack (value value) 'enum-value))

+ (13 (push-stack stack value 'class))))

+

+(defun push-smoke-stack (stack lisp-value smoke-type)

+ (typecase smoke-type

+ (smoke-type

+ (cond

+ ((class-p smoke-type)

+ (push-stack2 stack

+ (convert-to-class (get-class smoke-type) lisp-value)

+ (type-id smoke-type)))

+; ((pointer-p smoke-type)

+ (t

+ (let ((cffi-type (get-type (name smoke-type))))

+ (if (null cffi-type)

+ (progn

+ ; (assert (typep lisp-value 'foreign-pointer)

+ ; (lisp-value)

+ ; "The lisp-value ~S is not a foreign-pointer."

+ ; lisp-value)

+ (push-stack2 stack

+ lisp-value

+ (type-id smoke-type)))

+ (multiple-value-bind (pointer args) (convert-to-foreign lisp-value

+ cffi-type)

+ (push-cleanup stack

+ #'(lambda ()

+ (free-converted-object pointer

+ cffi-type

+ args)))

+ (push-stack2 stack

+ pointer

+ (type-id smoke-type))))))))

+; (t (push-stack2 stack lisp-value (type-id smoke-type)))))

+ (t (push-lisp-object stack lisp-value smoke-type))))

+

+(defgeneric push-lisp-object (stack object class)

+ (:documentation "Push the OBJECT on STACK."))

+

+(defun set-smoke-stack (stack args arguments)

+ "Pushes the arguments ARGS onto the Smoke stack STACK."

+ (when (null args)

+ (assert (null arguments)

+ ()

+ "To few arguments supplied. Missing: ~A" arguments))

+ (unless (null args)

+ (assert (not (null arguments))

+ ()

+ "To many arguments suppliend (Arguments ~A)." args)

+ (push-smoke-stack stack (first args) (first arguments))

+ (set-smoke-stack stack (rest args) (rest arguments))))

+

+(defmacro with-stack ((stack args types) &body body)

+ (let ((smoke-stack (gensym "STACK")))

+ `(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args)))

+ (let ((,stack (make-call-stack ,smoke-stack)))

+ (unwind-protect

+ (progn

+ (set-smoke-stack ,stack ,args

+ ,types)

+ ,@body)

+ (mapcar #'funcall (cleanup-stack ,stack)))))))

+

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

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

+ (ecase (type-id type)

+ (0 (let ((cffi-type (get-type (name type))))

+ (if (null cffi-type)

+ (progn

+ ;(warn "Unknown translation from ~A to lisp." (name type))

+ (foreign-slot-value stack-item 'smoke-stack-item 'voidp))

+ (convert-from-foreign (foreign-slot-value stack-item

+ 'smoke-stack-item

+ 'voidp)

+ cffi-type))))

+ (1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))

+ (2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))

+ (3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))

+ (4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short)))

+ (5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort)))

+ (6 (foreign-slot-value stack-item 'smoke-stack-item 'int))

+ (7 (foreign-slot-value stack-item 'smoke-stack-item 'uint))

+ (8 (foreign-slot-value stack-item 'smoke-stack-item 'long))

+ (9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong))

+ (10 (foreign-slot-value stack-item 'smoke-stack-item 'float))

+ (11 (foreign-slot-value stack-item 'smoke-stack-item 'double))

+ (12 (make-instance 'enum

+ :value (foreign-slot-value stack-item 'smoke-stack-item 'enum-value)

+ :type type))))

+

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

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

+

+(defun object-to-lisp (object type)

+ (if (class-p type)

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

+ (if (has-pointer-p object)

+ (get-object object)

+ (instance-to-lisp object (find-smoke-class class) type)))

+ nil))

+

+

+

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

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

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

+ 'smoke-stack-item

+ 'class)

+ type))

+

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

+ "Returns the Lisp representation of STACK-ITEM"

+ (cond

+ ((void-p type)

+ (values))

+ ((class-p type)

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

+ (t

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

+

+

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

+++ new-smoke/src/objects/type.lisp 2014-09-28 09:39:50.000000000 +0200

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

+(in-package #:smoke)

+

+(defclass smoke-type (smoke-symbol)

+ ()

+ (:documentation "A type"))

+

+

+(defmethod get-struct-slot-value ((type smoke-type) slot-name)

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

+ 'smoke-type slot-name))

+

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

+ :smoke smoke))

+

+(defmethod name ((type smoke-type))

+ (get-struct-slot-value type 'name))

+

+(defun type= (type1 type2)

+ (and t ;(pointer-eq (smoke type1)

+ ; (smoke type2))

+ (= (id type1)

+ (id type2))))

+

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

+ (boole boole-and (get-struct-slot-value type 'flags)

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

+

+(defun stack-p (type)

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

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

+

+(defun reference-p (type)

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

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

+

+(defun pointer-p (type)

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

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

+

+(defmethod const-p ((type smoke-type))

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

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

+

+(defun class-p (type)

+ "Returns T when TYPE is a smoke class"

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

+ (/= -1 (get-struct-slot-value type 'class))))

+

+(defun type-id (type)

+ "Returns the ID of TYPE."

+ (boole boole-and (get-struct-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)."

+ (null (name type)))

+

+(defgeneric get-class (smoke-symbol)

+ (:documentation "Returns the smoke-class associated with SMOKE-SYMBOL."))

+

+(defmethod get-class ((type smoke-type))

+ "Return the smoke-class of TYPE."

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

+ (type)

+ "The type ~S is not a smoke class." (name type))

+ (make-instance 'smoke-class

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

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

+++ new-smoke/src/package.lisp 2014-09-28 09:39:50.000000000 +0200

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

+(defpackage #:cxx-support

+ (:use #:cl)

+ (:export #:enum

+ #:enum=

+ #:enum-logand

+ #:value

+ #:enum-type

+ #:enum-case

+ #:enum-cases

+ #:enum-ecase))

+

+(defpackage #:smoke

+ (:use #:cl #:asdf #:cffi #:trivial-garbage #:bordeaux-threads #:cxx-support)

+ (:export #:init

+

+ #:make-smoke-classes

+

+ #:new-object

+ #:delete-object

+ #:smoke-call

+ #:call

+

+ #:name

+ #:id

+ #:type=

+

+ #:define-methods

+

+ #:cxx-bool

+

+ #:pointer))

+

+(defpackage #:cxx

+ (:use) ;; do not use #:cl

+ (:export #:class))

+

+

+

+(in-package #:smoke)

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

+++ new-smoke/src/run-test.lisp 2014-09-28 09:39:50.000000000 +0200

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

+#|

+exec sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@"

+|#

+

+;(asdf:operate 'asdf:load-op 'smoke :verbose nil)

+;(require :sb-cover)

+;(declaim (optimize sb-cover:store-coverage-data))

+;(asdf:oos 'asdf:load-op :smoke :force t)

+(require :smoke-tests)

+(in-package :smoke-tests)

+(setup)

+(5am:run!)

+;(smoke-destruct *kde-binding*)

+;(smoke-destruct *qt-binding*)

+;(sb-cover:report "./report/")

+(sb-ext:quit)

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

+++ new-smoke/src/smoke-c/CMakeLists.txt 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,11 @@

+find_package(Qt4 REQUIRED)

+set(QT_DONT_USE_QTGUI true)

+include(${QT_USE_FILE})

+

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

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

+

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

+

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

+ LIBRARY DESTINATION lib)

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

+++ new-smoke/src/smoke-c/class.lisp 2014-09-28 09:39:50.000000000 +0200

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

+(in-package #:smoke)

+

+(defcenum smoke-class-flags

+ "Class properties"

+ (:constructor #x01)

+ (:copy-constructor #x02)

+ (:virtual-destructor #x04)

+ (:undefined #x10))

+

+

+(defcstruct smoke-class

+ "Describe a class"

+ (name :string)

+ (external cxx-bool)

+ (parents smoke-index)

+ (class-function :pointer)

+ (enum-function :pointer)

+ (flags :unsigned-short))

+

+(defcfun smoke-find-class :void

+ (m :pointer smoke-module-index)

+ (smoke :pointer)

+ (name :string))

+

+(defcfun smoke-class-id smoke-index

+ (smoke :pointer)

+ (name :string))

+

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

+ (smoke-base :pointer)

+ (base-class smoke-index))

+

+(defcfun smoke-cast :pointer

+ (smoke :pointer)

+ (object :pointer)

+ (from smoke-index)

+ (to smoke-index))

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

+++ new-smoke/src/smoke-c/csmokebinding.cpp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,84 @@

+#include "csmokebinding.h"

+

+#include <QtGlobal>

+

+namespace cl_smoke

+{

+

+/** @class Binding

+ * @brief The Smoke binding.

+ */

+

+

+/** @typedef Binding::destructed

+ * Callback when a Smoke object is destructed.

+ *

+ * @param binding Smoke binding of the object

+ * @param class_id class id

+ * @param object the object

+ */

+

+

+/** @typedef Binding::dispatch_method

+ * Callback when a Smoke method gets called.

+ *

+ * @param binding Smoke binding of @a object

+ * @param method index of the method

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

+ * @param args the arguments to the method

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

+ *

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

+ *when the default method shall be invoked.

+ */

+

+/** Constructor.

+ * @param smoke the Smoke module

+ * @param destruct destruct callback

+ * @param dispatch method dispatch callback

+ */

+Binding::Binding(Smoke *smoke, destructed destruct,

+ dispatch_method dispatch)

+ : SmokeBinding(smoke),

+ destruct(destruct),

+ dispatch(dispatch)

+{

+ Q_ASSERT(smoke);

+ Q_ASSERT(destruct);

+ Q_ASSERT(dispatch);

+}

+

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

+void

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

+{

+ destruct(this, classId, obj);

+}

+

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

+bool

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

+ Smoke::Stack stack, bool abstract)

+{

+ return dispatch(this, method, object, stack, abstract);

+}

+

+/**

+ * @todo Returning a const char* would be better

+ */

+char*

+Binding::className(Smoke::Index classId)

+{

+ return const_cast<char*>(smoke->classes[classId].className);

+}

+

+/** Gets the Smoke instance associated with the binding.

+ * @return a pointer to the Smoke instance

+ */

+Smoke*

+Binding::get_smoke() const

+{

+ return smoke;

+}

+

+} // namespace cl_smoke

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

+++ new-smoke/src/smoke-c/csmokebinding.h 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,40 @@

+#ifndef CSMOKEBINDING_H

+#define CSMOKEBINDING_H

+

+#include <smoke.h>

+

+namespace cl_smoke

+{

+

+class Binding : public SmokeBinding

+{

+ public:

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

+ void* object);

+

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

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

+

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

+

+ virtual void

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

+

+ virtual bool

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

+ Smoke::Stack stack, bool abstract);

+

+ virtual char*

+ className(Smoke::Index classId);

+

+ Smoke*

+ get_smoke() const;

+

+ private:

+ const destructed destruct;

+ const dispatch_method dispatch;

+};

+

+} // namespace cl_smoke

+

+#endif // CSMOKEBINDING_H

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

+++ new-smoke/src/smoke-c/method.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,58 @@

+(in-package #:smoke)

+

+(declaim (optimize (debug 3)))

+

+(defcenum smoke-method-flags

+ "Method flags"

+ (:static #x01)

+ (:const #x02)

+ (:copy-constructor #x04)

+ (:internal #x08)

+ (:enum #x10)

+ (:constructor #x20)

+ (:destructor #x40)

+ (:protected #x80))

+

+(defcstruct smoke-method

+ "Describe a method"

+ (class smoke-index)

+ (name smoke-index)

+ (arguments smoke-index)

+ (num-args :unsigned-char)

+ (flags :unsigned-char)

+ (return-type smoke-index)

+ (method smoke-index))

+

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

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

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

+++ new-smoke/src/smoke-c/smoke-c-util.cpp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,18 @@

+

+/** @file

+ * \@brief Utility functions

+ */

+

+extern "C" {

+

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

+ *

+ * @return the size of bool

+ */

+int

+smoke_sizeof_bool()

+{

+ return sizeof(bool);

+}

+

+} // extern "C"

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

+++ new-smoke/src/smoke-c/smoke-c.cpp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,430 @@

+#include "csmokebinding.h"

+

+#include <smoke.h>

+

+#include <stdexcept>

+#include <QtGlobal>

+

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

+ */

+

+

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

+namespace cl_smoke

+{

+

+/** A Binding */

+typedef void* smoke_binding;

+

+/** Casts the void pointer smoke_binding to the Binding class.

+ * @param smoke the smoke binding

+ *

+ * @return pointer to the Binding instance

+ */

+static inline

+Binding*

+get_smoke_binding(smoke_binding binding)

+{

+ return static_cast<Binding*>(binding);

+}

+

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

+ * @param smoke the Smoke module

+ *

+ * @return pointer to the Smoke module.

+ */

+static inline

+Smoke*

+get_smoke(void* smoke)

+{

+ return static_cast<Smoke*>(smoke);

+}

+} // namespace cl_smoke

+

+using namespace cl_smoke;

+

+extern "C" {

+

+/** Returns the Smoke module of a Smoke binding.

+ * @related cl_smoke::Binding

+ * @param binding the Binding

+ *

+ * @return the Smoke module

+ */

+void*

+smoke_get_smoke(smoke_binding binding)

+{

+ return get_smoke_binding(binding)->get_smoke();

+}

+

+/** Creates a new Smoke binding.

+ * The binding is allocated on the heap an can be freed with smoke_destruct().

+ * @related cl_smoke::Binding

+ * @param smoke pointer to a Smoke module instance

+ * @param destruct callback for object destruction

+ * @param dispatch method dispatch callback

+ *

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

+ */

+smoke_binding

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

+{

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

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

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

+}

+

+/** Deletes the smoke binding.

+ * @related cl_smoke::Binding

+ */

+void

+smoke_destruct(smoke_binding binding)

+{

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

+ delete get_smoke_binding(binding);

+}

+

+/** Gets a Smoke modules name.

+ * @param smoke the Smoke module

+ *

+ * @return the module name

+ */

+const char*

+smoke_get_module_name(void* smoke)

+{

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

+}

+

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

+/// Class

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

+

+/** Finds a class.

+ * @param c pointer to write the result to

+ * @param smoke the smoke module

+ * @param name the name of the class

+ */

+void

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

+{

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

+}

+

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

+ * @param smoke the Smoke module

+ * @param name the class name

+ *

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

+ */

+Smoke::Index

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

+{

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

+ Q_ASSERT(m.smoke == smoke);

+

+ return m.index;

+}

+

+

+

+/** Gets the number of classes.

+ *

+ * @return the number of classes

+ */

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

+ */

+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

+ *

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

+ */

+const struct Smoke::Class*

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

+{

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

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

+}

+

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

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

+ * @param class_index the class index

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

+ * @param base_index the index of the base class

+ *

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

+ */

+int

+smoke_is_derived_from(void* smoke, Smoke::Index class_index, void* smoke_base, Smoke::Index base_index)

+{

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

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

+

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

+ get_smoke(smoke_base), base_index);

+}

+

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

+ * @param smoke the Smoke module

+ * @param class_index the class index

+ *

+ * @return the index of a parent

+ */

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

+ */

+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

+ */

+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

+ */

+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

+ */

+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

+ */

+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

+ * @param class_index index of the class

+ * @param method_name method name

+ */

+void

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

+ Smoke::Index class_index, const char* method_name)

+{

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

+ method_name);

+ if(m->index > 0)

+ m->index = 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

+ */

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

+ *

+ * @return NULL on success or a description of the exception that occurred.

+ */

+const char*

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

+ }

+ catch (std::exception& e)

+ {

+ qFatal(e.what());

+ return e.what();

+ }

+ catch (...)

+ {

+ qFatal("exception");

+ return NULL;

+ }

+

+ return NULL;

+}

+

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

+/// Type

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

+

+/** Gets the number of types.

+ * @param smoke the Smoke module

+ *

+ * @return the number of types

+ */

+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

+ */

+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

+ *

+ * @return the index of the type

+ */

+Smoke::Index

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

+{

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

+}

+

+/** Casts an object.

+ * @param smoke the Smoke module

+ * @param object the objec

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

+ * @param to the class index to cast to

+ *

+ * @return the casted object

+ */

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

+

+ 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

+ */

+Smoke::Index

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

+{

+ Q_ASSERT(ambiguous >= 0);

+

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

+}

+

+} // extern "C"

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

+++ new-smoke/src/smoke-c/smoke-c.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,64 @@

+(in-package #:smoke)

+

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

+ (define-foreign-library libsmokeqt

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

+ (t (:default "libsmokeqt")))

+

+ (use-foreign-library libsmokeqt)

+

+ (use-foreign-library libsmoke-c)

+)

+

+

+

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

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

+ (defcfun smoke-sizeof-bool :int)

+ (defun cffi-bool-type ()

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

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

+ (intern (format nil "UINT~A" (* 8

+ (smoke-sizeof-bool)))

+ ; (foreign-funcall smoke-sizeof-bool :int)))

+ (find-package :keyword)))

+

+ (defmacro defcxxbool ()

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

+

+(defcxxbool)

+

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

+

+(defctype smoke-binding :pointer

+ "A Smoke binding")

+

+(defctype smoke-index :short

+ "An index")

+

+(defcfun smoke-init smoke-binding

+ (smoke :pointer)

+ (destruct :pointer)

+ (dispatch :pointer))

+

+(defcfun smoke-destruct :void

+ (smoke smoke-binding))

+

+(defcstruct smoke-module-index

+ "asdf"

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

+

+(defcfun smoke-get-smoke :pointer

+ (smoke-binding smoke-binding))

+

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

+ (smoke :pointer))

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

+++ new-smoke/src/smoke-c/stack.lisp 2014-09-28 09:39:50.000000000 +0200

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

+(in-package #:smoke)

+

+(defcunion smoke-stack-item

+ "A variable on the Smoke stack"

+ (voidp :pointer)

+ (bool cxx-bool)

+ (char :char)

+ (uchar :unsigned-char)

+ (short :short)

+ (ushort :unsigned-short)

+ (int :int)

+ (uint :unsigned-int)

+ (long :long)

+ (ulong :unsigned-long)

+ (float :float)

+ (double :double)

+ (enum-value :long)

+ (class :pointer))

+

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

+ "A Smoke call stack.")

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

+++ new-smoke/src/smoke-c/type.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,28 @@

+(in-package #:smoke)

+

+(defcenum smoke-type-flags

+ "Type properties"

+ (:type-id #x0F)

+

+ (:stack #x10)

+ (:pointer #x20)

+ (:reference #x30)

+

+ (:const #x40))

+

+(defcstruct smoke-type

+ "A type"

+ (name :string)

+ (class smoke-index)

+ (flags :unsigned-short))

+

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

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

+++ new-smoke/src/smoke.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,138 @@

+(in-package #:smoke)

+

+(declaim (optimize (debug 3)))

+

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

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

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

+ object (pointer stack))

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

+

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

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

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

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

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

+ (null-pointer) args))

+

+(defun enum-call (method)

+ "Return the enum value for METHOD."

+ ;; FIXME:

+ ;; we could use static call, but QGraphicsEllipseItem::Type has

+ ;; wrongly QGraphicsGridLayout as return type. Smoke ignores case

+ ;; and confuses it with the member function type() ??

+ ;; (27.2.09)

+ ;;

+ (assert (enum-p method))

+ (with-stack (stack nil nil)

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

+ (pointer

+ (pointer-call

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

+ method-name)

+ (null-pointer) args)))

+ (let ((object (instance-to-lisp object (find-smoke-class class)

+ (return-type)))

+|#

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

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

+ (s-call

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

+ pointer))

+ (setf pointer (null-pointer)))

+

+(defun delete-object (object)

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

+ (s-call

+ (make-smoke-method 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 init (smoke)

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

+

+(defun call (object method-name &rest args)

+ (smoke-call (class-of object)

+ (pointer object)

+ method-name

+ args))

+

+(defmethod documentation ((class smoke-standard-class) (doc-type t))

+ (format nil "~@[~A~%~]C++ name: ~A" (call-next-method) (name class)))

+

+(defmethod documentation ((gf smoke-gf) (doc-type t))

+ (let ((methods (all-methods (name gf))))

+ (format nil "~@[~A~%~]~{~T~A~%~}"

+ (call-next-method)

+ (sort (mapcar #'method-declaration methods) #'string<=))))

+

+(defun all-methods (name)

+ "Returns a list of all methods named NAME."

+ (let ((methods))

+ (maphash #'(lambda (address value)

+ (declare (ignore value))

+ (let ((smoke (make-pointer address)))

+ (map-methods #'(lambda (method)

+ (when (and (string= name (name method))

+ (not (enum-p method)))

+ (push (make-instance 'smoke-method

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

+ smoke))

+

+(defun fgrep-classes (smoke str)

+ (map-classes #'(lambda (class)

+ (when (search str (name class))

+ (format t "~A~%" (name class))))

+ smoke))

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

+++ new-smoke/src/test.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,10 @@

+#|

+exec sbcl --noinform --load $0 --end-toplevel-options "$@"

+|#

+

+(sb-ext:disable-debugger)

+(require :smoke)

+(in-package :smoke)

+(setup)

+(test)

+(sb-ext:quit)

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

+++ new-smoke/src/tests.lisp 2014-09-28 09:39:50.000000000 +0200

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

+(in-package :smoke)

+

+(5am:def-suite smoke-suite)

+(5am:in-suite smoke-suite)

+

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

+++ new-smoke/src/translate.lisp 2014-09-28 09:39:50.000000000 +0200

@@ -0,0 +1,26 @@

+(in-package :smoke)

+

+(defvar *type-map* (make-hash-table :test 'equal))

+

+(defun get-type (name)

+ "Return the CFFI type for NAME."

+ (gethash name *type-map*))

+

+(defun add-type (name type)

+ "Registers the CFFI type TYPE with NAME."

+ (setf (gethash name *type-map*) type))

+

+(defun setup-type-map ()

+ "Setup C string <-> Lisp string translation."

+ (add-type "char*" :string)

+ (add-type "const char*" :string))

+

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

+ (setup-type-map))

+

+(defgeneric convert-to-class (smoke-class object))

+

+;(defmethod convert-to-class (smoke-class (pointer cffi:foreign-pointer))

+(defmethod convert-to-class (smoke-class pointer)

+ (assert (cffi:pointerp pointer))

+ pointer)

--- old-smoke/src/utils/get-value.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/utils/get-value.lisp 2014-09-28 09:39:50.000000000 +0200

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

+(in-package #:smoke)

+

+ (defun read-new-value ()

+ (format *query-io* "Enter a new value: ")

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