Sun Aug 2 12:12:41 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cleanup C++ to Lisp translation

--- old-smoke/smoke.mbd 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/smoke.mbd 2014-10-30 07:05:55.000000000 +0100

@@ -32,7 +32,6 @@

(:needs "CMakeLists")

(:components

"package"

- ("translate" (:needs "package"))

("using-type" (:needs "package"))

("overload-resolution" (:needs "package" "smoke" "using-type"))

("sb-optimize" (:for :sbcl) (:needs "overload-resolution"))

@@ -42,14 +41,14 @@

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

("cxx-method" (:needs "package"))

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

- ("method" (:needs "clos" "overload-resolution"))

+ ("smoke-to-clos" (:needs "clos" "overload-resolution"))

(:objects module

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

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

(:serial t)

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

"instance" "stack"))

(:smoke-c module

- (:needs "package" "translate")

+ (:needs "package")

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

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

--- old-smoke/src/bindings.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/bindings.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -1,6 +1,7 @@

(in-package :smoke)

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

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

+ "The Smoke C++ binding classes to which virtual method calls are dispatched.")

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

;; load additional modules while threads are running.

@@ -22,6 +23,7 @@

binding)))

(defstruct smoke-array

+ "A C array."

(pointer (null-pointer) :type foreign-pointer)

(length 0 :type (smoke-index 0)))

@@ -40,7 +42,8 @@

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

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

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

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

+ "All loaded Smoke modules.")

(defun init-smoke-module (module)

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

--- old-smoke/src/class-map.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/class-map.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -5,35 +5,31 @@

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

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

-

(defun id-class-map (smoke)

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

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

- (assert value

- ()

+ (assert value ()

"Unknown smoke module ~A ~A."

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

value))

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

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

+ (setf (gethash (pointer-address (smoke-module-pointer smoke))

+ *smoke-id-class-map*)

new-value))

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

- (setf (id-class-map smoke)

- (make-hash-table)))

+ (setf (id-class-map smoke) (make-hash-table)))

(defun add-id (smoke-class class)

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

- (setf (gethash (id smoke-class)

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

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

class))

(defun find-smoke-class (class)

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

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

- (ret (gethash (id class)

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

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

(assert (not (null ret))

()

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

--- old-smoke/src/clos.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/clos.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -9,7 +9,6 @@

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

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

-

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

"Defines a function to transform a string."

(let ((output (gensym))

@@ -120,51 +119,33 @@

()

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

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

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

+ (superclass standard-class))

t)

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

+(defmethod closer-mop:validate-superclass ((class cxx:class)

+ (superclass smoke-standard-class))

t)

-(defmethod reinitialize-instance :around

- ((class smoke-standard-class)

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

- (apply

- #'call-next-method class

- :direct-superclasses (or direct-superclasses

- (list (find-class

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

-

-(defmethod initialize-instance :around

- ((class smoke-standard-class)

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

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

- (apply

- #'call-next-method class

- :direct-superclasses (or direct-superclasses

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

- args))

-

-(defmethod reinitialize-instance :around

- ((class cxx:class)

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

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

- (direct-superclasses)

- "No superclass supplied for class ~A" class)

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

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

- ((first direct-superclasses))

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

- (apply

- #'call-next-method class

- :id (id superclass)

- :smoke (smoke superclass)

- :direct-superclasses direct-superclasses

- args)))

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

+;; STANDARD-OBJECT.

+(defun init-smoke-standard-class (class next-method

+ &rest args &key direct-superclasses

+ &allow-other-keys)

+ (apply next-method class

+ :direct-superclasses (or direct-superclasses

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

+ args))

+

+(defmethod initialize-instance :around ((class smoke-standard-class) &rest args)

+ (apply #'init-smoke-standard-class class #'call-next-method args))

+

+(defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args)

+ (apply #'init-smoke-standard-class class #'call-next-method args))

+

-(defmethod initialize-instance :around

- ((class cxx:class)

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

+(defun init-cxx-class (class next-method &rest args &key direct-superclasses

+ &allow-other-keys)

(assert (not (null direct-superclasses))

(direct-superclasses)

"No superclass sup-lied for class ~A" class)

@@ -175,14 +156,19 @@

(assert (virtual-destructor-p superclass)

()

"The class ~A has a non virtual destructor." superclass)

-

(apply

- #'call-next-method class

+ next-method class

:id (id superclass)

:smoke (smoke superclass)

:direct-superclasses direct-superclasses

args)))

+(defmethod reinitialize-instance :around ((class cxx:class) &rest args)

+ (apply #'init-cxx-class class #'call-next-method args))

+

+(defmethod initialize-instance :around ((class cxx:class) &rest args)

+ (apply #'init-cxx-class class #'call-next-method args))

+

(defun smoke-class-symbol (smoke-class)

"Returns the Lisp class-name of SMOKE-CLASS:"

(if (external-p smoke-class)

@@ -248,6 +234,9 @@

((object-pointer :pointer))

(declare (optimize (speed 3)))

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

+ ;; The destructed callback can be the result of deleting the object

+ ;; in a finalizer. In that case the object is already removed from

+ ;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.

(when object

(remove-finalizer object)

(remove-object object-pointer)

@@ -256,6 +245,7 @@

(declaim (inline argument-to-lisp))

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

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

+ ;; It looks like there is no stack allocation in Qt virtual method signatures.

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

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

@@ -266,8 +256,7 @@

(stack-to-args (inc-pointer stack

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

(next arg)

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

- 'smoke-stack-item)

+ (push (argument-to-lisp (mem-ref stack 'smoke-stack-item)

arg)

args))))

@@ -295,13 +284,15 @@

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

(remove-finalizer converted-value)

(when (typep value 'smoke-standard-object)

- (transfer-ownership-to value object)))))))

+ (remove-object (pointer value))))))))

+ ; (transfer-ownership-to value object)))))))

(defun get-gf-for-method (smoke-method)

(declare (smoke-method smoke-method)

(optimize (speed 3)))

(symbol-function (lispify (name smoke-method) "CXX")))

+;; Receive virutal function calls.

(defcallback dispatch-method :boolean

((binding :pointer)

(method smoke-index)

@@ -310,82 +301,81 @@

(abstract :boolean))

(declare (optimize (speed 3)))

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

- ;; FIXME:

- ;;(assert object

- ;; (object)

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

- (if (and object (typep (class-of object) 'cxx:class))

- ;; Do not allow overwriting methods of classes the users has

- ;; not derived from (like in C++), to reduce overhead.

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

- :smoke (gethash (pointer-address

- (smoke-get-smoke binding))

- *smoke-modules*)

- :id method)))

- (loop

- (restart-case

- (return-from dispatch-method

- (let ((gf (get-gf-for-method method)))

- (declare (function gf))

- (if (null (gf-methods gf))

- (progn

- (when abstract

- (error "Abstract method ~A called."

- (method-declaration method)))

- nil)

- (if object

- (progn

- (put-returnvalue stack

- (apply gf object

- (stack-to-args

- (inc-pointer stack

- (foreign-type-size

- 'smoke-stack-item))

- (get-first-argument method)))

- (return-type method)

- object)

- t)

- nil))))

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

- (call-default ()

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Call default implementation ~A instead."

- method))

- :test (lambda (condition)

- (declare (ignore condition))

- (not abstract))

- (return-from dispatch-method nil))

- (use-returnvalue (return-value)

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Supply a return value for ~A."

- (method-declaration method)))

- :test (lambda (condition)

- (declare (ignore condition))

- (not (void-p (return-type method))))

- :interactive (lambda ()

- (format *query-io* "~&Enter a new return value: ")

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

- (put-returnvalue stack return-value

- (return-type method)

- (get-object object-ptr))

- (return-from dispatch-method t))

- (return ()

- :report (lambda (stream)

- (declare (stream stream))

- (format stream "Return void for ~A."

- (method-declaration method)))

- :test (lambda (condition)

- (declare (ignore condition))

- (void-p (return-type method)))

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

- (retry ()

- :report (lambda (stream)

- (declare (stream stream))

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

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

- nil))))

+ ;; The Lisp OBJECT can be gc'ed but we might still receive a

+ ;; QObject destructed event when the C++ instance is deleted in

+ ;; the finalizer. Thus OBJECT might be NIL.

+ (when (and object (typep (class-of object) 'cxx:class))

+ ;; Do not allow overwriting methods of classes the users has

+ ;; not derived from (like in C++), to reduce overhead.

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

+ :smoke (gethash (pointer-address

+ (smoke-get-smoke binding))

+ *smoke-modules*)

+ :id method)))

+ (loop

+ (restart-case

+ (return-from dispatch-method

+ (let ((gf (get-gf-for-method method)))

+ (declare (function gf))

+ (if (null (gf-methods gf))

+ (progn

+ (when abstract

+ (error "Abstract method ~A of ~A called."

+ (method-declaration method) object))

+ nil)

+ (if object

+ (progn

+ (put-returnvalue

+ stack

+ (apply gf object

+ (stack-to-args

+ (inc-pointer stack (foreign-type-size

+ 'smoke-stack-item))

+ (get-first-argument method)))

+ (return-type method) object)

+ t)

+ nil))))

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

+ (call-default ()

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream

+ "Call default implementation ~A instead."

+ method))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (not abstract))

+ (return-from dispatch-method nil))

+ (use-returnvalue (return-value)

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Supply a return value for ~A."

+ (method-declaration method)))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (not (void-p (return-type method))))

+ :interactive (lambda ()

+ (format *query-io* "~&Enter a new return value: ")

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

+ (put-returnvalue stack return-value

+ (return-type method)

+ (get-object object-ptr))

+ (return-from dispatch-method t))

+ (return ()

+ :report (lambda (stream)

+ (declare (stream stream))

+ (format stream "Return void for ~A."

+ (method-declaration method)))

+ :test (lambda (condition)

+ (declare (ignore condition))

+ (void-p (return-type method)))

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

+ (retry ()

+ :report (lambda (stream)

+ (declare (stream stream))

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

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

+ nil))))

;;FIXME use CHANGE-CLASS instead?

(defun cast (object class)

@@ -408,9 +398,7 @@

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

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

- (cast object smoke-class))

-

+;; The constructor name is the name of the class minus any namespace parts.

(defun constructor-name (class)

(let ((name-start (search "::" (name class) :from-end t)))

(if name-start

@@ -478,8 +466,8 @@

(declare (type smoke-standard-object object)

(optimize (speed 3)))

(when (member object (owned-objects new-owner))

- (cerror "ignore" "~A has already been called for ~A."

- #'keep-wrapper object))

+ (cerror "ignore" "~A has already been added to ~A."

+ object new-owner))

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

(declaim (inline remove-wrapper-object))

--- old-smoke/src/cxx-method.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/cxx-method.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -1,13 +1,11 @@

(in-package :smoke)

(defclass cxx-generic-function (standard-generic-function)

- ((gf-methods :initform nil

+ ((gf-methods :initform nil :type list

:accessor gf-methods

- :type list

- :documentation "Generic functions for different argument counts."))

+ :documentation "gf for different argument counts."))

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

- (:documentation

- "A generic function that can be overloaded by argument count."))

+ (:documentation "gf that can be overloaded by argument count."))

(defclass cxx-method-generic-function (standard-generic-function)

((generic-function :accessor cxx-generic-function

@@ -36,8 +34,7 @@

((integer 0) argument-count)

(values (or cxx-method-generic-function null)))

(find-if #'(lambda (gf)

- (= argument-count

- (argument-count gf)))

+ (= argument-count (argument-count gf)))

(gf-methods cxx-generic-function)))

(defun cxx-method-generic-function-name (cxx-generic-function argument-count)

@@ -80,8 +77,9 @@

(defun push-method (method cxx-generic-function)

"Adds METHOD to a cxx-method-generic-function of CXX-GENERIC-FUNCTION."

(declare (optimize (speed 3)))

- (let ((generic-function (ensure-gf-by-argument-count cxx-generic-function

- (method-argument-count method))))

+ (let ((generic-function (ensure-gf-by-argument-count

+ cxx-generic-function

+ (method-argument-count method))))

(add-method generic-function method)))

(defun unpush-method (method)

--- old-smoke/src/method.lisp 2014-10-30 07:05:55.000000000 +0100

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

@@ -1,159 +0,0 @@

-(in-package :smoke)

-

-(defun constant-definition (package method smoke)

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

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

- (let ((symbol

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

- "Qt")

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

- "+")

- package)

- (lispify (concatenate 'string

- (name (get-class method))

- ".+"

- (name method) "+")

- package))))

- (values

- `(define-constant ,symbol

- (make-instance 'enum

- :value ,(enum-call method)

- :type (make-instance 'smoke-type

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

- :smoke ,smoke))

- :test #'enum=)

- symbol)))

-

-(defun static-method-symbol (package method)

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

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

- (lispify (concatenate 'string

- (if (string= (name class)

- "QGlobalSpace")

- nil

- (concatenate 'string

- (name class)

- "."))

- (name method))

- package)))

-

-(defun static-method-definition (package method &optional (argument-count -1))

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

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

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

- (method-name (name method))

- (name (static-method-symbol package method)))

- (values

- `(defun ,name ,(if (< argument-count 0)

- '(&rest args)

- (make-lambda argument-count))

- (call-using-args (find-class (quote ,(lispify (name class) package)))

- ,method-name

- ,(if (< argument-count 0)

- 'args

- `(list ,@(make-lambda argument-count)))))

- name)))

-

-(defun ensure-generic-methods (symbols-names)

- "Ensures the generic functions for SYMBOLS-NAMES."

- (declare (list symbols-names)

- (optimize (speed 3)))

- (dolist (symbol-name symbols-names)

- (ensure-generic-function (first symbol-name)

- :cxx-name (rest symbol-name)

- :generic-function-class 'smoke-gf

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

- (export (first symbol-name) :cxx)))

-

-(defun setf-method-definition (method)

- `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)

- (,(lispify (name method) :cxx) object new-value)

- new-value))

-

-(defmacro sizes= ((smoke)&rest arrays)

- `(and ,@(loop for array in arrays collect

- `(= (smoke-array-length (,array ,smoke))

- ,(smoke-array-length (funcall (fdefinition array)

- (eval smoke)))))))

-

-(defmacro check-recompile (smoke)

- "Raises an error when the fasl of the DEFINE-METHOS was not compiled against

-the current smoke module."

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

- (unless (sizes= (,smoke)

- smoke-module-methods

- smoke-module-method-names

- smoke-module-method-maps

- smoke-module-classes

- smoke-module-types)

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

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

-

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

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

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

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

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

-;;; multiple definition of a function with the same name.

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

- (constants)

- (functions)

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

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

- (exports))

- (map-methods

- #'(lambda (method)

- (when (and (enum-p method)

- ;; FIXME workaround for

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

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

- "KGlobalSettings")))

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

- (push def

- constants)

- (push export exports)))

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

- (not (constructor-p method))

- (not (enum-p method))

- (not (eql nil (name method)))

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

- (let ((name (name method)))

- (when (and (starts-with-subseq "set" name)

- (> (length name) 3)

- (upper-case-p (char name 3))

- (= 1 (get-arguments-length method)))

- (unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))

- (setf (gethash (lispify name :cxx) setf-function-symbols) t)

- (push (setf-method-definition method) functions)))

- (setf (gethash (lispify name "CXX") generics)

- name))

- (when (static-p method)

- (let* ((function-symbol (static-method-symbol package method))

- (methods (gethash function-symbol function-symbols)))

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

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

- (eval smoke))

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

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

- :smoke (eval smoke)

- :id (abs id))))

- (multiple-value-bind (definition export)

- (static-method-definition

- package

- method

- (if (< 0 id)

- (get-arguments-length method)

- -1))

- (push definition functions)

- (push export exports))))

- `(progn (check-recompile ,smoke)

- ,@functions

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

- ;; eval on startup for class map.

- (make-smoke-classes ,package ,smoke))

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

- (ensure-generic-methods ',(hash-table-alist generics)))

- ,@constants

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

- (export (quote ,exports) ,package)))))

-

--- old-smoke/src/object-map.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/object-map.lisp 2014-10-30 07:05:55.000000000 +0100

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

(make-weak-hash-table :weakness weakness :synchronized t)

(make-weak-hash-table :synchronized t)))

-

#+openmcl

(let ((ccl::*shared-hash-table-default* t))

(defun make-synchronized-hash-table (&key weakness)

@@ -35,8 +34,8 @@

(defvar *object-map* (make-synchronized-hash-table :weakness :value)

"Contains all objects constructed by Smoke, that are not yet destructed;

-except object with a non virtual destructor which had their ownership transferred

-to C++.")

+except object with a non virtual destructor which had their ownership

+transferred to C++.")

(eval-on-save ()

(loop for object being the hash-value of *object-map* do

@@ -59,11 +58,7 @@

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

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

-(defun remove-if-exists (pointer)

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

-

(defun remove-object (pointer)

- (declare (optimize (speed 3)))

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

(cerror "ignore" "No object to remove for pointer ~A." pointer)))

@@ -111,12 +106,11 @@

(make-instance class :pointer pointer))

(funcall next)

(format *debug-io* "done~%"))))))

-

+

(defun add-object (object)

"Adds OBJECT to the pointer -> object map. It can later be retrieved

with GET-OBJECT."

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

- ()

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

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

(get-object (pointer object)) object)

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

--- old-smoke/src/objects/class.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/objects/class.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -1,17 +1,18 @@

(in-package #:smoke)

(defclass smoke-class ()

- ((id :initform 0 :type smoke-index :reader id :initarg :id)

- (smoke :type smoke-module :reader smoke :initarg :smoke)))

+ ((id :initform 0 :type smoke-index

+ :reader id :initarg :id)

+ (smoke :type smoke-module

+ :reader smoke :initarg :smoke)))

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

(make-instance 'smoke-class :id id :smoke smoke))

-

(declaim (inline smoke-class-pointer))

(defun smoke-class-pointer (class)

- (mem-aref (the foreign-pointer (smoke-array-pointer (smoke-module-classes

- (smoke class))))

+ (mem-aref (the foreign-pointer

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

'smoke-class

(the smoke-index (id class))))

@@ -42,7 +43,8 @@

(defun external-p (class)

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

- (declare (optimize (speed 3)))

+ (declare (type smoke-class class)

+ (optimize (speed 3)))

(class-slot-value class 'external))

(defun get-class-flag (class flag)

@@ -68,7 +70,6 @@

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

@@ -107,8 +108,10 @@

T))

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

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

- (smoke-module-pointer (smoke base-class)) (id base-class)))

+ (smoke-is-derived-from (smoke-module-pointer (smoke class))

+ (id class)

+ (smoke-module-pointer (smoke base-class))

+ (id base-class)))

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

@@ -124,8 +127,7 @@

(if (= 0 class-index)

classes

(smoke-add-superclass

- class (append classes

- (list

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

- class-index)))

+ class

+ (append classes

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

(1+ index)))))

--- old-smoke/src/objects/enum.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/objects/enum.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -3,7 +3,6 @@

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

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

-;;;

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

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

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

@@ -31,7 +30,7 @@

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

(assert (smoke-type= (enum-type enum)

- enum-type)

+ enum-type)

(enum enum-type)

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

@@ -39,7 +38,7 @@

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

(declare (enum enum1 enum2))

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

- (enum-type enum2))

+ (enum-type enum2))

(enum1 enum2)

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

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

@@ -67,8 +66,8 @@

"Keyform returns a number; cases are enums."

`(case ,keyform

,@(loop for case in cases

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

- ,@(rest case)))))

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

+ ,@(rest case)))))

(defun enum-logand (&rest enums)

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

--- old-smoke/src/objects/method.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/objects/method.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -14,7 +14,8 @@

(smoke-method-id method)))

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

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

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

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

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

(call-next-method)

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

@@ -52,8 +53,7 @@

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

(smoke-method-smoke method)))

:pointer

- (the (smoke-index 0)

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

+ (the (smoke-index 0) (method-slot-value method 'name))))

;smoke-find-method

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

@@ -136,8 +136,7 @@

"public"))

(defun modifiers (method)

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

- (static-p method)))

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

(defun return-type (method)

"Returns the return type of METHOD."

@@ -253,7 +252,6 @@

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

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

-

(defun build-argument-list (list argument)

(if (end-p argument)

list

--- old-smoke/src/objects/stack.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/objects/stack.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -17,19 +17,19 @@

(optimize (speed 3)))

(%make-call-stack

:pointer smoke-stack

- :top (inc-pointer smoke-stack

- #.(foreign-type-size 'smoke-stack-item))))

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

(defun push-stack (stack value type)

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

- 'smoke-stack-item type) value)

+ (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)

+ value)

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

(define-compiler-macro push-stack (&whole form stack value type)

(if (constantp type)

`(progn

(setf (foreign-slot-value (call-stack-top ,stack)

- 'smoke-stack-item ,type) ,value)

+ 'smoke-stack-item ,type)

+ ,value)

(incf-pointer (call-stack-top ,stack)

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

form))

@@ -100,22 +100,13 @@

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

(declare (optimize (speed 3)))

(ecase (type-id type)

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

- (if (null cffi-type)

- (progn

- ;; FIXME warn but not on void**

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

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

- (let* ((pointer (foreign-slot-value stack-item

- 'smoke-stack-item

- 'voidp))

- (value (convert-from-foreign pointer cffi-type)))

- (when (stack-p type)

- ;; FIXME free-translated-object is not intended for this;

- ;; param is NIL for now.

- (cffi:free-translated-object pointer cffi-type nil))

- value

- ))))

+ (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))

+ (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

+ 'voidp)))

+ (prog1 (funcall (car translation) pointer)

+ (when (stack-p type)

+ (funcall (cdr translation) pointer))))

+ (error "Do not know how to convert the type ~A to Lisp." type)))

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

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

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

@@ -128,7 +119,8 @@

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

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

(12 (make-instance 'enum

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

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

+ 'enum-value)

:type type))))

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

@@ -137,19 +129,24 @@

(defun object-to-lisp (object type)

(declare (optimize (speed 3)))

- (if (class-p type)

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

- (if (has-pointer-p object)

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

+ (if (has-pointer-p object)

+ (if (derived-p (class-of (get-object object))

+ (get-class type))

(get-object object)

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

- nil))

+ (progn

+ (cerror "Remove the old object."

+ "The object at pointer ~A is ~A but should be a ~A."

+ object (get-object object) type)

+ (remove-object object)

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

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

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

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

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

- 'smoke-stack-item

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

'class)

type))

@@ -157,9 +154,30 @@

"Returns the Lisp representation of STACK-ITEM"

(declare (optimize (speed 3)))

(cond

- ((void-p type)

- (values))

- ((class-p type)

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

- (t

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

+ ((void-p type) (values))

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

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

+

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

+

+(defun error-no-free (object)

+ (error "Can not free object at ~A." object))

+

+(defmacro define-to-lisp-translation (type-names &optional

+ (conversion-function-name 'identity)

+ (free-function-name 'error-no-free))

+ `(progn ,@(loop for type-name in (ensure-list type-names)

+ collect `(setf (gethash ,type-name *to-lisp-translations*)

+ (cons ',conversion-function-name

+ ',free-function-name)))))

+

+(defmacro define-pointer-typedef (type-names lisp-type)

+ (declare (ignore lisp-type))

+ `(progn

+ (define-to-lisp-translation ,type-names identity identity)))

+ ;; not needed

+ ;;(define-from-lisp-translation ,type-names ,lisp-type)))

+

+(define-to-lisp-translation ("void*" "const void*" "void**"))

+

+(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)

--- old-smoke/src/objects/type.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/objects/type.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -77,8 +77,8 @@

form))

(defmacro allocation-flag-p (type flag)

- ;; Can't just use #'get-type-flag since it

- ;; can only be one of :stack, :reference and :pointer.

+ ;; Can't just use #'get-type-flag since it can only be one of

+ ;; :stack, :reference and :pointer.

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

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

(logand #x30

@@ -121,11 +121,11 @@

;; No need to convert the entire C string to lisp like in:

;; (null (name type)))

(declare (optimize (speed 3)))

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

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

- 'smoke-type

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

- :char)))

+ (zerop (mem-ref (mem-aref (smoke-array-pointer

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

+ 'smoke-type

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

+ :char)))

(defgeneric get-class (smoke-symbol)

@@ -133,9 +133,7 @@

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

"Return the smoke-class of TYPE."

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

+ (assert (class-p type)

(type)

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

- (make-smoke-class-from-id

- (smoke type)

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

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

+ (make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))

--- old-smoke/src/overload-resolution.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -404,12 +404,14 @@

;; (foo pointer) assumes pointer to point to a QByteArray, but

;; actually the conversion sequence QByteArray(pointer) should be

;; used. When pointer is a null pointer it fails horribly!.

+ ;;

+ ;; But it is needed for passing the int pointer in QApplication(int&, char**).

(when (and (or (= 0 (type-id type)) ; voidp

(= 13 (type-id type))) ; class

(object.typep 'foreign-pointer))

(make-match 'pointer-conversion 'identity nil

- :from (find-class 't)

- :to (find-class 't)))) ;; FIXME get the class when applicable

+ :from (find-class 't)

+ :to (find-class 't)))) ;; FIXME get the class when applicable

(defun+using-type conversion object (object type)

--- old-smoke/src/package.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/package.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -30,6 +30,8 @@

#:cxx-bool

#:define-from-lisp-translation

+ #:define-to-lisp-translation

+ #:define-pointer-typedef

#:make-cleanup-pointer

#:make-auto-pointer

--- old-smoke/src/smoke-c/csmokebinding.cpp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/smoke-c/csmokebinding.cpp 2014-10-30 07:05:55.000000000 +0100

@@ -1,6 +1,7 @@

#include "csmokebinding.h"

#include <QtGlobal>

+#include <QDebug>

namespace cl_smoke

{

@@ -13,6 +14,7 @@

/** @typedef Binding::destructed

* Callback when a Smoke object is destructed.

*

+ * @param class_index Index of the object's class.

* @param object pointer to the object

*/

--- old-smoke/src/smoke-c/smoke-c.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/smoke-c/smoke-c.lisp 2014-10-30 07:05:55.000000000 +0100

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

(define-foreign-library libsmoke-c-util

(:unix "libsmoke-c-util.so")

(t (:default "libsmoke-c-util")))

-

(use-foreign-library libsmokeqt)

-

(use-foreign-library libsmoke-c))

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

+++ new-smoke/src/smoke-to-clos.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -0,0 +1,159 @@

+(in-package :smoke)

+

+(defun constant-definition (package method smoke)

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

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

+ (let ((symbol

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

+ "Qt")

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

+ "+")

+ package)

+ (lispify (concatenate 'string

+ (name (get-class method))

+ ".+"

+ (name method) "+")

+ package))))

+ (values

+ `(define-constant ,symbol

+ (make-instance 'enum

+ :value ,(enum-call method)

+ :type (make-instance 'smoke-type

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

+ :smoke ,smoke))

+ :test #'enum=)

+ symbol)))

+

+(defun static-method-symbol (package method)

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

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

+ (lispify (concatenate 'string

+ (if (string= (name class)

+ "QGlobalSpace")

+ nil

+ (concatenate 'string

+ (name class)

+ "."))

+ (name method))

+ package)))

+

+(defun static-method-definition (package method &optional (argument-count -1))

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

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

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

+ (method-name (name method))

+ (name (static-method-symbol package method)))

+ (values

+ `(defun ,name ,(if (< argument-count 0)

+ '(&rest args)

+ (make-lambda argument-count))

+ (call-using-args (find-class (quote ,(lispify (name class) package)))

+ ,method-name

+ ,(if (< argument-count 0)

+ 'args

+ `(list ,@(make-lambda argument-count)))))

+ name)))

+

+(defun ensure-generic-methods (symbols-names)

+ "Ensures the generic functions for SYMBOLS-NAMES."

+ (declare (list symbols-names)

+ (optimize (speed 3)))

+ (dolist (symbol-name symbols-names)

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

+ :cxx-name (rest symbol-name)

+ :generic-function-class 'smoke-gf

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

+ (export (first symbol-name) :cxx)))

+

+(defun setf-method-definition (method)

+ `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)

+ (,(lispify (name method) :cxx) object new-value)

+ new-value))

+

+(defmacro sizes= ((smoke)&rest arrays)

+ `(and ,@(loop for array in arrays collect

+ `(= (smoke-array-length (,array ,smoke))

+ ,(smoke-array-length (funcall (fdefinition array)

+ (eval smoke)))))))

+

+(defmacro check-recompile (smoke)

+ "Raises an error when the fasl of the DEFINE-METHOS was not compiled against

+the current smoke module."

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

+ (unless (sizes= (,smoke)

+ smoke-module-methods

+ smoke-module-method-names

+ smoke-module-method-maps

+ smoke-module-classes

+ smoke-module-types)

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

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

+

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

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

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

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

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

+;;; multiple definition of a function with the same name.

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

+ (constants)

+ (functions)

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

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

+ (exports))

+ (map-methods

+ #'(lambda (method)

+ (when (and (enum-p method)

+ ;; FIXME workaround for

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

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

+ "KGlobalSettings")))

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

+ (push def

+ constants)

+ (push export exports)))

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

+ (not (constructor-p method))

+ (not (enum-p method))

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

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

+ (let ((name (name method)))

+ (when (and (starts-with-subseq "set" name)

+ (> (length name) 3)

+ (upper-case-p (char name 3))

+ (= 1 (get-arguments-length method)))

+ (unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))

+ (setf (gethash (lispify name :cxx) setf-function-symbols) t)

+ (push (setf-method-definition method) functions)))

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

+ name))

+ (when (static-p method)

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

+ (methods (gethash function-symbol function-symbols)))

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

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

+ (eval smoke))

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

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

+ :smoke (eval smoke)

+ :id (abs id))))

+ (multiple-value-bind (definition export)

+ (static-method-definition

+ package

+ method

+ (if (< 0 id)

+ (get-arguments-length method)

+ -1))

+ (push definition functions)

+ (push export exports))))

+ `(progn (check-recompile ,smoke)

+ ,@functions

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

+ ;; eval on startup for class map.

+ (make-smoke-classes ,package ,smoke))

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

+ (ensure-generic-methods ',(hash-table-alist generics)))

+ ,@constants

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

+ (export (quote ,exports) ,package)))))

+

--- old-smoke/src/smoke.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/smoke.lisp 2014-10-30 07:05:55.000000000 +0100

@@ -31,12 +31,10 @@

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

(foreign-funcall-pointer

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

- 'smoke-class

- 'class-function)

+ 'smoke-class 'class-function)

()

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

- 'smoke-method

- 'method)

+ 'smoke-method 'method)

:pointer object-pointer

smoke-stack stack-pointer

:void))

@@ -51,25 +49,21 @@

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

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

-

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

- (s-call

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

- pointer args))

+ (s-call (make-smoke-method-from-name class method-name) pointer args))

(defun static-call (smoke class-name method-name &rest args)

- (s-call

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

- method-name)

- (null-pointer) args))

+ (s-call (make-smoke-method-from-name (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)

+ ;; and confuses it with the member function type() ?? (27.2.09)

;;

(assert (enum-p method))

(with-stack (stack nil nil)

@@ -81,41 +75,35 @@

Calls the destructor and frees the memory."

(declare (optimize (speed 3)))

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

- (s-call

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

- pointer)))

+ (s-call (make-smoke-method-from-name class method-name) pointer)))

(defun delete-object (object)

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

(s-call

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

- (pointer object)))

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

+ (pointer object)))

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

(defun set-binding (object)

"Sets the Smoke binding for OBJECT, that receives its callbacks."

(declare (optimize (speed 3)))

(with-foreign-object (stack 'smoke-stack-item 2)

- (setf (foreign-slot-value (mem-aref stack

- 'smoke-stack-item

- 1)

- 'smoke-stack-item

- 'voidp)

+ (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1)

+ 'smoke-stack-item 'voidp)

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

(foreign-funcall-pointer

(foreign-slot-value (smoke-class-pointer (class-of object))

- 'smoke-class

- 'class-function)

+ 'smoke-class 'class-function)

()

smoke-index 0 ;; set binding method index

- :pointer (pointer object) smoke-stack stack

+ :pointer (pointer object)

+ smoke-stack stack

:void)))

(defun init (smoke module)

"Returns the a new Smoke binding for the Smoke module SMOKE."

(use-foreign-library libsmoke-c)

- (let* ((binding (smoke-init smoke

- (callback destructed)

+ (let* ((binding (smoke-init smoke (callback destructed)

(callback dispatch-method))))

(setf (binding smoke) binding

(smoke-module-pointer module) smoke

@@ -127,17 +115,16 @@

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

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

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

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

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

+ pointer-symbol-map)

symbol))

(defun get-smoke-variable-for-pointer (pointer)

"Returns the SYMBOL of the variable whose value is POINTER."

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

(defun call (object method-name &rest args)

- (smoke-call (class-of object)

- (pointer object)

- method-name

- args))

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

+ method-name args))

(defmethod documentation ((class smoke-standard-class) (doc-type (eql 't)))

(declare (optimize (speed 3)))

@@ -150,7 +137,6 @@

(call-next-method)

(sort (mapcar #'method-declaration methods) #'string<=))))

-

(declaim (inline cstring=))

(defun cstring= (string1 string2)

"Returns T when the C strings STRING1 and STRING2 are equal

@@ -196,10 +182,10 @@

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

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

(load-foreign-library ',library))

+

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

- (defcvar (,variable ,variable-name

- :read-only t

- :library ,library) :pointer)

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

+ :pointer)

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

(length function-name)

function-name)

@@ -213,7 +199,6 @@

(register-smoke-module-var ',smoke-module))

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

-

(defun fgrep-classes (smoke str)

(map-classes #'(lambda (class)

(when (search str (name class))

--- old-smoke/src/translate.lisp 2014-10-30 07:05:55.000000000 +0100

+++ new-smoke/src/translate.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,27 +0,0 @@

-(in-package :smoke)

-

-(defvar *type-map* (make-hash-table :test 'equal))

-

-(defun get-type (name)

- "Return the CFFI type for NAME."

- (gethash name *type-map*))

-

-(defun add-type (name type)

- "Registers the CFFI type TYPE with NAME."

- (setf (gethash name *type-map*) type))

-

-(defun setup-type-map ()

- "Setup C string <-> Lisp string translation."

- (add-type "char*" :string)

- (add-type "const char*" :string))

-

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

- (setup-type-map))

-

-(defgeneric convert-to-class (smoke-class object))

-

-;(defmethod convert-to-class (smoke-class (pointer cffi:foreign-pointer))

-(defmethod convert-to-class (smoke-class pointer)

- (declare (ignore smoke-class))

- (assert (cffi:pointerp pointer))

- pointer)