Fri Apr 17 17:26:55 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Experimental C++ style overload resolution.
diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd
--- old-smoke/smoke.mbd 2014-09-28 09:40:10.000000000 +0200
+++ new-smoke/smoke.mbd 2014-09-28 09:40:10.000000000 +0200
@@ -34,13 +34,14 @@
("CMakeLists.txt" static-file)
"package"
("translate" (:needs "package"))
+ ("overload-resolution" (:needs "package" "smoke"))
("smoke" (:needs "smoke-c" "objects" "clos"))
("object-map" (:needs "objects"))
("class-map" (:needs "package"))
("bindings" (:needs "package"))
("cxx-method" (:needs "package"))
("clos" (:needs "smoke-c" "cxx-method" "objects" "object-map" "class-map" "bindings"))
- ("method" (:needs "clos"))
+ ("method" (:needs "clos" "overload-resolution"))
(:objects module
(:needs "smoke-c" "utils")
(:serial t)
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp 2014-09-28 09:40:10.000000000 +0200
+++ new-smoke/src/clos.lisp 2014-09-28 09:40:10.000000000 +0200
@@ -73,7 +73,7 @@
(go default)))
(define-string-transform cxx-to-lisp
- "Returns camelCase STRING in lisp-style."
+ "Returns camelCase STRING in lisp-style."
(begin
"Strip leadind Q or K."
(case char
@@ -86,6 +86,8 @@
(#\: (go-next namespace))
(#\_ (append-char #\-)
(go-next default))
+ (#\ (append-char #\-) ;; space (cast operators)
+ (go-next default))
(t (append-char (char-upcase char))
(if (lower-case-p char)
(go-next camel-case)
@@ -241,11 +243,14 @@
(defmethod no-applicable-method ((gf smoke-gf) &rest args)
"Calls the smoke method."
(declare (optimize (speed 3)))
+ (call-using-args (first args) (name gf) (rest args)))
+#|
(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 cxx-method-generic-function) method)
"Adds a method which calls the smoke method, to make call-next-method work."
@@ -369,11 +374,29 @@
(name class)
args))
-(defun call-constructor (object args)
- (pointer-call (make-smoke-constructor (class-of object)
- args)
- (null-pointer)
- args))
+(defun call-constructor (object arguments)
+ (if (null arguments)
+ (let ((method (find-smoke-method (class-of object)
+ (name (class-of object)))))
+ (pointer-call method (null-pointer)))
+ (multiple-value-bind (rank method sequence)
+ (find-best-viable-function (name (class-of object))
+ (mapcar #'(lambda (a)
+ (let ((type (type-of a)))
+ (if (subtypep type 'smoke-standard-object)
+ (class-of a)
+ type)))
+ arguments)
+ (class-of object))
+ (when (null method)
+ (error "No construtor ~A for ~S"
+ object arguments))
+ (pointer-call method (null-pointer)
+ (mapcar #'funcall sequence arguments)))))
+; (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)
diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp
--- old-smoke/src/method.lisp 2014-09-28 09:40:10.000000000 +0200
+++ new-smoke/src/method.lisp 2014-09-28 09:40:10.000000000 +0200
@@ -59,11 +59,13 @@
(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)))
+ (call-using-args (find-class (quote ,(lispify (name class))))
+ ,method-name 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)
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:40:10.000000000 +0200
+++ new-smoke/src/objects/method.lisp 2014-09-28 09:40:10.000000000 +0200
@@ -24,14 +24,35 @@
"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
(defun make-smoke-method (class name)
- "Returns the method called NAME of CLASS.
-Signals a undefined-method condition when no method was found."
+ "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)
diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp
--- old-smoke/src/overload-resolution.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp 2014-09-28 09:40:10.000000000 +0200
@@ -0,0 +1,395 @@
+;;; C++ overload resolution
+;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf
+
+(in-package :smoke)
+(declaim (optimize (debug 3)))
+
+(deftype smoke-index (&optional (lower -32768) (upper 32767))
+ `(integer ,lower ,upper))
+
+(defun mung-char-p (character)
+ (declare (character character))
+ (case character
+ ((#\$ #\? #\#) t)))
+
+(defun binary-search-method-names (name smoke start end)
+ (declare ((smoke-index 1) start end)
+ (string name)
+ (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)
+ (- (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)
+ (declare (string name)
+ ((smoke-index 1) start end)
+ (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 if super classes of CLASS; one or every smoke module
+that can be reaced by CLASS super classes. The returned super classes
+are as secific as possible."
+ (let ((modules (list class)))
+ (dolist (super-class (closer-mop:class-direct-superclasses class) modules)
+ (when (and (typep super-class 'smoke-standard-class)
+ (not (eql super-class (find-class 'smoke-standard-object))))
+ (dolist (c (smoke-modules super-class))
+ (setf modules (adjoin c modules :key #'smoke)))))))
+
+(defun candidate-functions (name argument-count class2)
+ "Returns a list of methods named NAME that take ARGUMENT-COUNT methods."
+ (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))
+
+
+
+(defconstant +no-match+ most-positive-fixnum)
+(defconstant +exact-match+ 0)
+(defconstant +promotion+ 1)
+(defconstant +conversion+ 2)
+
+(defclass std-conversion ()
+ ()
+ (:documentation "A conversion"))
+
+(defclass no-match (std-conversion)
+ ((rank :reader rank
+ :allocation :class
+ :initform +no-match+)))
+(defclass exact-match (std-conversion)
+ ((rank :reader rank
+ :allocation :class
+ :initform +exact-match+)))
+
+(defclass promotion (std-conversion)
+ ((rank :reader rank
+ :allocation :class
+ :initform +promotion+)))
+
+(defclass number-conversion (std-conversion)
+ ((rank :reader rank
+ :allocation :class
+ :initform +conversion+)))
+
+(defclass pointer-conversion (std-conversion)
+ ((rank :reader rank
+ :allocation :class
+ :initform (1+ +conversion+))
+ (from :reader from
+ :initarg :from)
+ (to :reader to
+ :initarg :to)))
+
+(defclass boolean-conversion (std-conversion)
+ ((rank :reader rank
+ :allocation :class
+ :initform (1+ +conversion+))))
+
+(defclass user-conversion (std-conversion)
+ ((rank :reader rank
+ :allocation :class
+ :initform (1+ +conversion+))))
+
+(defgeneric conversion< (conversion1 conversion2)
+ (:documentation
+ "Retruns true when CONVERSION1 is better than CONVERSION2.")
+ ;; 13.3.3.2 Ranking implicit conversion sequences
+ ;; 4
+ (:method (conversion1 conversion2)
+ (or (null conversion2)
+ (< (rank conversion1) (rank conversion2))))
+ (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
+ (if (eq (from conversion1) (from conversion2))
+ ;; A->B < A->C <=> B subclass of C
+ (subtypep (to conversion1) (to conversion2))
+ (if (eq (to conversion1) (to conversion2))
+ ;; B->A < C->A <=> B subclass of C
+ (subtypep (from conversion1) (from conversion2))
+ nil))))
+
+(defgeneric conversion= (conversion1 conversion2)
+ (:documentation
+ "Returns true when the standard conversion sequence CONVERSION1
+ is indistinguishable from CONVERSION2.")
+ (:method (conversion1 conversion2)
+ (= (rank conversion1) (rank conversion2)))
+ (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
+ (and (not (conversion< conversion1 conversion2))
+ (not (conversion< conversion2 conversion1)))))
+
+(defun max-conversion (conversion1 conversion2)
+ (if (null conversion2)
+ conversion1
+ (if (conversion< conversion1 conversion2)
+ conversion2
+ conversion1)))
+
+(defun conversion-sequence-for-type (class type &optional user)
+ (if (exact-match-using-class class type)
+ (values (make-instance 'exact-match) #'identity)
+ (multiple-value-bind (match function)
+ (promotion-using-class class type)
+ (if match
+ (values (make-instance 'promotion) function)
+ (multiple-value-bind (m2 function2)
+ (conversion-using-class class type)
+ (if m2
+ (values m2 function2)
+ (if user
+ (user-conversion-using-class class type)
+ (values nil nil))))))))
+
+(defun standard-conversion-sequence-using-classes (method classes &optional user)
+ (let ((max-rank)
+ (conversions))
+ ;(format t "~A~%~3T~A~%" method classes)
+ (loop for type in (arguments method)
+ for class in classes do
+ ;(format t "~%C ~A ~A~%" type class)
+ (multiple-value-bind (rank function)
+ (conversion-sequence-for-type class type user)
+ (when (null rank)
+ (setf max-rank nil)
+ (return nil))
+ (setf max-rank (max-conversion rank max-rank))
+ (push function conversions)))
+ (values max-rank (reverse conversions))))
+
+(defun conversion-sequence-using-classes (method classes)
+ (standard-conversion-sequence-using-classes method classes t))
+
+(defun find-best-viable-function (name classes class)
+ (find-best-viable-function2 #'conversion-sequence-using-classes
+ name classes class))
+
+(defun find-best-viable-function2 (get-sequence name classes class)
+ (declare (type (function (t list) (values t function)) get-sequence))
+ (let ((candidate-functions (candidate-functions name (length classes)
+ class))
+ (best-rank (make-instance 'no-match))
+ (best-method)
+ (conversions))
+ (loop for method in candidate-functions do
+ (multiple-value-bind (rank method-conversions)
+ (funcall get-sequence method classes)
+ (when (and rank (conversion< rank best-rank))
+ (setf best-rank rank)
+ (setf best-method method)
+ (setf conversions method-conversions)
+ (when (conversion= rank (make-instance 'exact-match))
+ (return)))))
+ (values best-rank 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 (alexandria:curry #'apply
+ #'(lambda (type-name lisp-type)
+ `(,type-name (subtypep ,class (quote ,lisp-type)))))
+ clauses)))
+
+(defun exact-match-using-class (class type)
+ (declare (values boolean))
+ (case (type-id type)
+ (0 (smoke-type-case (type class)
+ ("const QString&" string)
+ ("const char*" string)
+ ("void*" cffi:foreign-pointer)
+ ("const void*" cffi:foreign-pointer)
+ ("void**" cffi:foreign-pointer)))
+ (1 (subtypep class 'boolean))
+ (2 (subtypep class 'character))
+ (6 (subtypep class 'integer))
+ (7 (subtypep class '(integer 0)))
+ (10 (subtypep class 'single-float))
+ (11 (subtypep class 'double-float))
+ (12 (subtypep class 'enum)) ;; FIXME enum-type
+ (13 (and (subtypep class (find-class 'smoke-standard-object))
+ (type= type class)))))
+
+(defun make-auto-pointer (pointer)
+ "Returns a pointer that frees the memory at POINTER when it is finalized."
+ (let ((address (pointer-address pointer)))
+ (tg:finalize pointer #'(lambda ()
+ (foreign-free (make-pointer address))))))
+
+(defun promotion-using-class (class type)
+ (declare (smoke-type type))
+ ;(values boolean (or nil function)))
+ (case (type-id type)
+ (0
+ (if (and (string= (name type)
+ "const char*")
+ ; (subtypep class '(simple-array character *)))
+ (subtypep class 'string))
+ (values t #'(lambda (string)
+ (make-auto-pointer (foreign-string-alloc string))))
+ (values nil nil)))
+ (6 (and (subtypep class 'enum)
+ (values t #'cxx-support:value)))))
+
+; (smoke-type-case (type class)
+; ("double" single-float)))
+
+(defun conversion-using-class (class type)
+ (if (and (class-p type)
+ (subtypep class 'smoke-standard-object)
+ (derived-p class
+ (get-class type)))
+ (values (make-instance 'pointer-conversion
+ :from class :to (find-smoke-class (get-class type)))
+ #'(lambda (o) (cast o (find-smoke-class (get-class type)))))
+ (if (and (string= (name type)
+ "void*")
+ (subtypep class (find-class 'smoke-standard-object)))
+ (values (make-instance 'pointer-conversion
+ :from class :to (find-class 't))
+ #'identity)
+ (if (= 0 (type-id type))
+ (values (make-instance 'pointer-conversion
+ :from class :to (find-class 't))
+ #'identity)
+ (values nil nil)))))
+
+(defun user-conversion-using-class (class type)
+ ;; (or (and (subtypep class 'smoke-standard-object)
+ ;;
+ ;; (fboundp (intern (format nil "OPERATOR-~@:(~A~)" (name type))
+ ;; :cxx)))))
+ (if (subtypep class 'smoke-standard-object)
+ (let ((method (find-smoke-method class
+ (format nil "operator ~A"
+ (if (class-p type)
+ (name (get-class type))
+ (name type))))))
+ (when (valid-p method)
+ (if (void-p type)
+ (warn "Conversion operators not supported by Smoke. Update Smoke.")
+ (values (make-instance 'user-conversion)
+ #'(lambda (o)
+ (format t "CALL ~A~%" o)
+ (s-call method (pointer o)))))))
+ (if (class-p type)
+ (multiple-value-bind (rank method sequence)
+ (find-best-viable-function2 #'standard-conversion-sequence-using-classes
+ (format nil "~A" (name (get-class type)))
+ (list class) (find-smoke-class
+ (get-class type)))
+ (if (conversion= rank (make-instance 'no-match))
+ (values nil nil)
+ (values (make-instance 'user-conversion)
+ #'(lambda (o)
+ (make-instance (find-smoke-class (get-class type))
+ :args (list o)))))))))
+
+#|
+(defun test-foo ()
+ (values
+ (multiple-value-list
+ (find-best-viable-function "setPen" (list 'string)
+ (find-class 'qt:painter)))
+ (multiple-value-list
+ (find-best-viable-function "QVariant" (list (find-class 'qt:color))
+ (find-class 'qt:variant)))))
+
+|#
+
+(defun call-sequence (method object sequence &rest args)
+ (s-call method object
+ (mapcar #'funcall sequence args)))
+
+(defun call-using-args (object-or-class name arguments)
+ (if (null arguments)
+ (let ((method (find-smoke-method (smoke-class-of object-or-class)
+ name)))
+ (if (static-p method)
+ (s-call method (null-pointer))
+ (s-call method (cast object-or-class (get-class method)))))
+ (multiple-value-bind (rank method sequence)
+ (find-best-viable-function name
+ (mapcar #'(lambda (a)
+ (let ((type (type-of a)))
+ (if (subtypep type 'smoke-standard-object)
+ (class-of a)
+ type)))
+ arguments)
+ (smoke-class-of object-or-class))
+ (when (null method)
+ (error "No applicable method ~A of ~A for ~S.
+Candidates are:~{~T~A~%~}."
+ name object-or-class arguments
+ (mapcar #'signature
+ (candidate-functions name
+ (length arguments)
+ (smoke-class-of object-or-class)))))
+ (if (static-p method)
+ (apply #'call-sequence method (null-pointer) sequence arguments)
+ (apply #'call-sequence method (cast object-or-class (get-class method))
+ sequence arguments)))))
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 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/smoke-c/cl_smoke.h 2014-09-28 09:40:10.000000000 +0200
@@ -0,0 +1,35 @@
+#include <smoke.h>
+
+
+/** @brief Common Lisp smoke binding namespace. */
+namespace cl_smoke
+{
+class Binding;
+
+/** 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
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:40:10.000000000 +0200
+++ new-smoke/src/smoke-c/method.lisp 2014-09-28 09:40:10.000000000 +0200
@@ -23,6 +23,22 @@
(return-type smoke-index)
(method smoke-index))
+(defcstruct smoke-method-map
+ "Maps a munged method."
+ (class-id smoke-index)
+ (name smoke-index)
+ (method smoke-index))
+
+(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))
+
(defcfun smoke-find-method :void
(m :pointer smoke-module-index)
(smoke :pointer)
@@ -43,7 +59,7 @@
(defcfun smoke-method-name-size smoke-index
(smoke :pointer))
-(defcfun smoke-call-method :string
+(defcfun smoke-call-method :void
(smoke :pointer)
(method smoke-index)
(object :pointer)
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:40:10.000000000 +0200
+++ new-smoke/src/smoke-c/smoke-c.cpp 2014-09-28 09:40:10.000000000 +0200
@@ -1,4 +1,5 @@
#include "csmokebinding.h"
+#include "cl_smoke.h"
#include <smoke.h>
@@ -6,51 +7,18 @@
#include <QtGlobal>
/** @file
- * \@brief C wrapper the Smoke bindings.
+ * @brief C wrapper the Smoke bindings.
*
- * \example examples/kde-hello-world.cpp
+ * @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
+ * @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" {
@@ -297,6 +265,23 @@
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
+ */
+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
@@ -317,10 +302,8 @@
* @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*
+void
smoke_call_method(void* smoke, Smoke::Index method, void* object,
Smoke::Stack stack)
{
@@ -344,15 +327,12 @@
catch (std::exception& e)
{
qFatal(e.what());
- return e.what();
+ return;
}
catch (...)
{
- qFatal("exception");
- return NULL;
+ qFatal("exception in C++ code.");
}
-
- return NULL;
}
///////////////////////////
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:40:10.000000000 +0200
+++ new-smoke/src/smoke-c/smoke-c.lisp 2014-09-28 09:40:10.000000000 +0200
@@ -1,5 +1,6 @@
(in-package #:smoke)
+#|
(eval-when (:load-toplevel :compile-toplevel :execute)
(define-foreign-library libsmokeqt
(:unix "libsmokeqt.so.2")
@@ -9,6 +10,7 @@
(use-foreign-library libsmoke-c)
)
+|#
@@ -28,7 +30,7 @@
(defcxxbool)
-(close-foreign-library 'libsmoke-c-util)
+;(close-foreign-library 'libsmoke-c-util)
(defctype smoke-binding :pointer
"A Smoke binding")