Mon May 11 13:07:39 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Prepare for overload resolution at compile time

--- old-smoke/smoke.mbd 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/smoke.mbd 2014-09-28 09:40:16.000000000 +0200

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

("CMakeLists.txt" static-file)

"package"

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

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

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

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

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

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

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

@@ -69,4 +70,5 @@

(:needs "package")

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

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

+ :alexandria

:trivial-garbage :bordeaux-threads))

--- old-smoke/src/clos.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -205,8 +205,6 @@

(lispify (name class))))

-

-

(defun make-smoke-classes (smoke)

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

(declare (optimize (speed 3))

@@ -228,7 +226,8 @@

(defclass smoke-gf (cxx-generic-function)

((cxx-name :reader name :initarg :cxx-name

- :type string))

+ :type string

+ :documentation "The C++ name of the method."))

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

(:documentation "Smoke generic function"))

@@ -244,13 +243,6 @@

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

@@ -260,6 +252,9 @@

gf

`(lambda ,lambda-list

(declare (optimize (speed 3)))

+ (call-using-args ,(first lambda-list) (name ,(cxx-generic-function gf))

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

+#|

(let ((method (find-method-using-args (smoke-class-of ,(first lambda-list))

(name ,(cxx-generic-function gf))

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

@@ -267,6 +262,7 @@

(s-call method (null-pointer) (list ,@lambda-list))

(s-call method (cast ,(first lambda-list) (get-class method))

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

+|#

(defcallback destructed :void

((binding :pointer)

@@ -379,24 +375,17 @@

(let ((method (find-smoke-method (class-of object)

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

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

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

+ (multiple-value-bind (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)

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

+ (mapcar #'(lambda (conversion argument)

+ (funcall conversion argument))

+ sequence arguments)))))

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

&key args &allow-other-keys)

@@ -418,7 +407,4 @@

(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/cxx-method.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/cxx-method.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -38,6 +38,11 @@

(argument-count gf)))

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

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

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

+ (alexandria:symbolicate (closer-mop:generic-function-name cxx-generic-function)

+ #\/ (write-to-string argument-count))))

+

(defun ensure-gf-by-argument-count (cxx-generic-function argument-count)

"Returns the generic-function of CXX-GENERIC-FUNCTION that takes

ARGUMENT-COUNT arguments. When none exists, one is created."

@@ -45,9 +50,13 @@

((integer 0) argument-count))

(or (find-generic-function-by-argument-count cxx-generic-function

argument-count)

- (let ((gf (make-instance 'cxx-method-generic-function

- :cxx-generic-function cxx-generic-function

- :lambda-list (make-lambda argument-count))))

+ (let* ((name (cxx-method-generic-function-name cxx-generic-function

+ argument-count))

+ (gf (make-instance 'cxx-method-generic-function

+ :name name

+ :cxx-generic-function cxx-generic-function

+ :lambda-list (make-lambda argument-count))))

+ (setf (fdefinition name) gf)

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

gf)))

@@ -136,3 +145,21 @@

(defmethod remove-method ((gf cxx-generic-function) method)

(unpush-method method gf)

(update-method gf 'remove-method method))

+

+#|

+(defun cxx-dispatch-compiler-macro (cxx-generic-function)

+ "Retruns a compiler-macro form for CXX-GENERIC-FUNCTION that

+precomputes the dispatching for the argument count, if possible."

+ ;; FIXME only applies when a defmethod with the right argument count

+ ;; has been defined, which is almost never.

+ `(define-compiler-macro ,(closer-mop:generic-function-name cxx-generic-function)

+ (&whole form object &rest args)

+ (let ((name (cxx-method-generic-function-name (fdefinition (first form))

+ (1+ (length args)))))

+ (if (fboundp name)

+ `(,name ,object ,@args)

+ form))))

+

+(defmethod initialize-instance :after ((gf cxx-generic-function) &key &allow-other-keys)

+ (eval (cxx-dispatch-compiler-macro gf)))

+|#

--- old-smoke/src/method.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/method.lisp 2014-09-28 09:40:16.000000000 +0200

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

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

@@ -61,21 +53,8 @@

`(defun ,name (&rest 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)

- "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 (symbols-names)

"Ensures the generic functions for SYMBOLS-NAMES."

(declare (list symbols-names)

@@ -91,8 +70,14 @@

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

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

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

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

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

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

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

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

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

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

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

@@ -137,7 +122,7 @@

`(progn (check-recompile ,smoke)

,@functions

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

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

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

(make-smoke-classes ,smoke))

,@constants

,@exports)))

--- old-smoke/src/object-map.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-09-28 09:40:16.000000000 +0200

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

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

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

+;; => use :synchronized of sbcl hash-table

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

(defun get-object (pointer)

--- old-smoke/src/objects/method.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/objects/method.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -273,6 +273,10 @@

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

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

+(defun internal-p (method)

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

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

+

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

(make-instance 'smoke-class

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

--- old-smoke/src/objects/stack.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/objects/stack.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -55,6 +55,8 @@

(typecase smoke-type

(smoke-type

(cond

+ ((cffi:pointerp lisp-value)

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

((class-p smoke-type)

(push-stack2 stack

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

--- old-smoke/src/overload-resolution.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/overload-resolution.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -4,15 +4,17 @@

(in-package :smoke)

(declaim (optimize (debug 3)))

-(deftype smoke-index (&optional (lower -32768) (upper 32767))

- `(integer ,lower ,upper))

-

(defun mung-char-p (character)

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

(declare (character character))

(case character

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

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

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

+NAME is not found."

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

+ ;; interrested in the munging.

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

(string name)

(optimize (speed 3)))

@@ -40,6 +42,7 @@

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

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

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

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

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

@@ -49,6 +52,8 @@

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

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

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

+that accept ARGUMENT-COUNT arguments."

(declare (string name)

((smoke-index 1) start end)

(optimize (speed 3)))

@@ -65,9 +70,9 @@

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

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

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

+are as specific as possible."

(let ((modules (list class)))

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

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

@@ -104,19 +109,15 @@

-(defconstant +no-match+ most-positive-fixnum)

(defconstant +exact-match+ 0)

(defconstant +promotion+ 1)

(defconstant +conversion+ 2)

(defclass std-conversion ()

- ()

+ ((function-name :accessor conversion-function-name

+ :initarg :conversion-function-name))

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

@@ -144,12 +145,12 @@

(defclass boolean-conversion (std-conversion)

((rank :reader rank

:allocation :class

- :initform (1+ +conversion+))))

+ :initform (+ 2 +conversion+))))

(defclass user-conversion (std-conversion)

((rank :reader rank

:allocation :class

- :initform (1+ +conversion+))))

+ :initform (+ 3 +conversion+))))

(defgeneric conversion< (conversion1 conversion2)

(:documentation

@@ -174,72 +175,101 @@

is indistinguishable from CONVERSION2.")

(:method (conversion1 conversion2)

(= (rank conversion1) (rank conversion2)))

+ (:method ((conversion1 (eql nil)) (conversion2 (eql nil)))

+ t)

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

(and (not (conversion< conversion1 conversion2))

(not (conversion< conversion2 conversion1)))))

(defun max-conversion (conversion1 conversion2)

+ "Returns the greater conversion of CONVERSION1 and 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)

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

+ (defun conversion-function (name &optional arg)

+ (if arg

+ `(if (using-typep)

+ `(,,name

+ (find-class ',(class-name ,arg)))

+ #'(lambda (object)

+ (funcall (fdefinition ,name)

+ object ,arg)))

+ `(if (using-typep)

+ ,name

+ (fdefinition ,name)))))

+

+(defmacro make-match (type &optional (name ''identity)

+ (argument nil)

+ &rest args)

+ (format t "~S: ~S~%" type name)

+ `(make-instance ,type

+ :conversion-function-name ,(conversion-function name argument)

+

+ ,@args))

+

+(defun+using-type get-conversion-sequence object (object type &optional user)

+ "Retruns a conversion sequence to convert a instance of type CLASS

+to an instance of type TYPE. When USER is true user conversions are considered."

+ (alexandria:if-let

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

+ (if (eql t match)

+ (make-match 'exact-match)

+ (make-match 'exact-match match))

+ (or (call-using-type promotion object type)

+ (call-using-type conversion object type)

+ (and user

+ (call-using-type user-conversion object type)))))

+

+(defun+using-types standard-conversion-sequence (method classes &optional user)

+ "Returns the conversion sequences to convert the arguments of types CLASSES

+to the types required by METHOD."

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

+ (let ((rank (call-using-type get-conversion-sequence class type user)))

(when (null rank)

(setf max-rank nil)

(return nil))

(setf max-rank (max-conversion rank max-rank))

- (push function conversions)))

+ (push (conversion-function-name rank) conversions)))

(values max-rank (reverse conversions))))

-(defun conversion-sequence-using-classes (method classes)

- (standard-conversion-sequence-using-classes method classes t))

+(defun+using-types conversion-sequence (method classes)

+ (call-using-types standard-conversion-sequence method classes t))

-(defun find-best-viable-function (name classes class)

- (find-best-viable-function2 #'conversion-sequence-using-classes

- name classes class))

+(defun+using-types find-best-viable-function (name arguments class)

+ "Returns the method named NAME of class CLASS that can be called

+using arguments of types TYPES with the lowest conversion sequence."

+ (call-using-types find-best-viable-function2

+ (function-using-types conversion-sequence)

+ name arguments class))

-(defun find-best-viable-function2 (get-sequence name classes class)

+(defun+using-types find-best-viable-function2 (get-sequence name objects class)

(declare (type (function (t list) (values t function)) get-sequence))

- (let ((candidate-functions (candidate-functions name (length classes)

+ (when (and (using-typep)

+ (not (typep class 'smoke-standard-class)))

+ (format t "ERROR TYPE~%")

+ (throw 'unspecific-type class))

+ (let ((candidate-functions (candidate-functions name (length objects)

class))

- (best-rank (make-instance 'no-match))

+ (best-rank)

(best-method)

(conversions))

(loop for method in candidate-functions do

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

- (funcall get-sequence method classes)

+ (funcall get-sequence method objects)

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

+ (when (conversion= rank (make-match 'exact-match))

(return)))))

- (values best-rank best-method conversions)))

+ (values best-method conversions)))

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

;; FIXME this is horribly inefficient

@@ -252,118 +282,166 @@

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

,@(mapcar (alexandria:curry #'apply

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

- `(,type-name (subtypep ,class (quote ,lisp-type)))))

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

clauses)))

-

-(defun exact-match-using-class (class type)

- (declare (values boolean))

+

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

+

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

+ &optional

+ (conversion-function-name 'identity))

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

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

+ #'(lambda (type)

+ (and (subtypep type ',lisp-type)

+ ',conversion-function-name))))))

+

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

+ foreign-pointer)

+

+;; FIXME grovel this?

+(deftype c-integer (ctype)

+ (let ((bits (* 8 (foreign-type-size ctype))))

+ (if (alexandria:starts-with-subseq

+ (symbol-name :unsigned)

+ (symbol-name ctype))

+ ;`(integer 0 ,(1- (expt 2 bits)))

+ `(unsigned-byte ,bits)

+ `(signed-byte ,bits))))

+ ;`(integer ,(- (expt 2 (1- bits)))

+ ; ,(1- (expt 2 (1- bits)))))))

+

+

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

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

+ "Test for an exact match."

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

-

+ (0

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

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

+ (1 (object.typep 'boolean))

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

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

+ (4 (object.typep '(c-integer :short)))

+ (5 (object.typep '(c-integer :unsigned-short)))

+ (6 (object.typep '(c-integer :int)))

+ (7 (object.typep '(c-integer :unsigned-int)))

+ (10 (object.typep 'single-float))

+ (11 (object.typep 'double-float))

+ (12 (object.typep 'enum)) ;; FIXME enum-type

+ (13 (and (object.typep (find-class 'smoke-standard-object))

+ (type= type (object.type-of))))))

+

+

+(defun make-cleanup-pointer (pointer cleanup-function)

+ (let ((address (pointer-address pointer)))

+ (tg:finalize pointer #'(lambda ()

+ (funcall cleanup-function

+ (make-pointer address))))))

+

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

+(defun coerce-c-string (string)

+ (make-auto-pointer (foreign-string-alloc string)))

+

+(defun coerce-enum (enum)

+ (cxx-support:value enum))

+

+(defun+using-type promotion object (object 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)))))

+ (0 (when (and (string= (name type) "const char*")

+ (object.typep 'string))

+ (make-match 'promotion 'coerce-c-string)))

+ (6 (when (object.typep 'enum)

+ (make-match 'promotion 'cocere-enum)))))

-; (smoke-type-case (type class)

-; ("double" single-float)))

+(defun coerce-cast (object to-class)

+ (cast object to-class))

-(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 coerce-to-void (object)

+ object)

+

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

+ (when (and (class-p type)

+ (object.typep 'smoke-standard-object)

+ (derived-p (object.type-of) (get-class type)))

+ (make-match 'pointer-conversion

+ 'coerce-cast

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

+ :from (object.type-of)

+ :to (find-smoke-class (get-class type)))))

+

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

+ (when (and (string= (name type) "void*")

+ (object.typep 'smoke-standard-object))

+ (make-match 'pointer-conversion

+ 'coerce-void

+ nil

+ :from (object.type-of)

+ :to (find-class 't))))

+

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

+ (when (and (= 0 (type-id type))

+ (object.typep 'foreign-pointer))

+ (make-match 'pointer-conversion 'identity nil

+ :from (object.type-of)

+ :to (find-class 't))))

+

+

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

+ (or (call-using-type conversion-cast object type)

+ (call-using-type conversion-void object type)

+ (call-using-type conversion-pointer object type)))

+

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

+ (or (call-using-type operator-conversion object type)

+ (call-using-type constructor-conversion object type)))

+

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

+ (when (object.typep 'smoke-standard-object)

+ (let ((method (find-smoke-method (object.type-of)

+ (format nil "operator ~A"

+ (if (class-p type)

+ (name (get-class type))

+ (name type))))))

+ (when (valid-p method)

+ (assert (not (void-p type))

+ ()

+ "Conversion operators not supported by Smoke.

+Update to Smoke >= r955426.")

+ (make-match 'user-conversion

+ (lispify (name method) :cxx))))))

+

+(defun coerce-to-class (object to-class)

+ (make-instance to-class

+ :args (list object)))

+

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

+ (when (class-p type)

+ (let ((to-class (find-smoke-class (get-class type))))

+ (multiple-value-bind (method sequence)

+ (call-using-types find-best-viable-function2

+ (if (using-typep)

+ #'standard-conversion-sequence-using-types

+ #'standard-conversion-sequence)

+ (format nil "~A" (name (get-class type)))

+ (list object) to-class)

+ (when method

+ (make-match 'user-conversion

+ 'coerce-to-class

+ to-class))))))

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

(s-call method object

- (mapcar #'funcall sequence args)))

+ (mapcar #'(lambda (conversion argument)

+ (funcall conversion argument))

+ sequence args)))

(defun call-using-args (object-or-class name arguments)

(if (null arguments)

@@ -372,17 +450,12 @@

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

+ (multiple-value-bind (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)

+ arguments

(smoke-class-of object-or-class))

(when (null method)

- (error "No applicable method ~A of ~A for ~S.

+ (error "No applicable method ~S of ~A for ~S.

Candidates are:~{~T~A~%~}."

name object-or-class arguments

(mapcar #'signature

@@ -393,3 +466,13 @@

(apply #'call-sequence method (null-pointer) sequence arguments)

(apply #'call-sequence method (cast object-or-class (get-class method))

sequence arguments)))))

+

+

+(defun cxx-coerce-p-using-type (type result-type)

+ "Returns true when an object of type TYPE can be convertet to an object

+of smoke type RESULT-TYPE."

+)

+

+

+(defun cxx-coerce (object result-type)

+)

--- old-smoke/src/smoke-c/class.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/smoke-c/class.lisp 2014-09-28 09:40:16.000000000 +0200

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

(:virtual-destructor #x04)

(:undefined #x10))

-

(defcstruct smoke-class

"Describe a class"

(name :string)

--- old-smoke/src/smoke-c/smoke-c.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/smoke-c/smoke-c.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -20,9 +20,7 @@

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

+ (intern (format nil "UINT~A" (* 8 (smoke-sizeof-bool)))

(find-package :keyword)))

(defmacro defcxxbool ()

@@ -38,6 +36,10 @@

(defctype smoke-index :short

"An index")

+(deftype smoke-index (&optional (lower -32768) (upper 32767))

+ "Smoke index."

+ `(integer ,lower ,upper))

+

(defcfun smoke-init smoke-binding

(smoke :pointer)

(destruct :pointer)

--- old-smoke/src/smoke.lisp 2014-09-28 09:40:16.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -65,17 +65,6 @@

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

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

+++ new-smoke/src/using-type.lisp 2014-09-28 09:40:16.000000000 +0200

@@ -0,0 +1,82 @@

+(in-package :smoke)

+

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

+ `(macrolet ((,(alexandria:symbolicate object '.typep)

+ (type)

+ `(typep ,',object ,type))

+ (,(alexandria:symbolicate object '.type-of) ()

+ `(class-of ,',object))

+ (using-typep () nil)

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

+ `(,function-name ,@args))

+ (call-using-type (function-name &rest args)

+ `(,function-name ,@args)))

+ ,@body))

+

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

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

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

+;could not be determined."

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

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

+ (subtypep object-type type)

+ (if subtype-p

+ t

+ (if valid-p

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

+ (subtypep type object-type)

+ (if subtype-p

+ (throw 'unspecific-type (values object-type type))

+ (if valid-p

+ nil

+ (throw 'unspecific-type (values object-type type)))))

+ (throw 'unspecific-type (values object-type))))))

+

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

+ `(macrolet ((,(alexandria:symbolicate object-type '.typep)

+ (type)

+ `(typep-using-type ,',object-type ,type))

+ (,(alexandria:symbolicate object-type '.type-of) ()

+ (quote ,object-type))

+ (using-typep () t)

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

+ `(,(alexandria:symbolicate function-name '-using-types)

+ ,@args))

+ (call-using-type (function-name &rest args)

+ `(,(alexandria:symbolicate function-name '-using-type)

+ ,@args)))

+ ,@body))

+

+(defmacro defun+using-type (name object lambda-list &body body)

+ "Defines the functions NAME and NAME-using-type where the argument

+OBJECT of LAMBDA-LIST is an object respective its type.

+For OBJECT the functions OBJECT.typep and OBJECT.type-of can be used."

+ `(progn

+ (with-object-as-object ,object

+ (defun ,name ,lambda-list

+ ,@body))

+ (with-object-as-type ,object

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

+ ,@body))))

+

+(defmacro defun+using-types (name lambda-list &body body)

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

+ `(,function-name ,@args))

+ (call-using-type (function-name &rest args)

+ `(,function-name ,@args))

+ (using-typep () nil)

+ (function-using-types (name)

+ `(function ,name)))

+ (defun ,name ,lambda-list

+ ,@body))

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

+ `(,(alexandria:symbolicate function-name '-using-types)

+ ,@args))

+ (call-using-type (function-name &rest args)

+ `(,(alexandria:symbolicate function-name '-using-type)

+ ,@args))

+ (using-typep () t)

+ (function-using-types (name)

+ `(function ,(alexandria:symbolicate name '-using-types))))

+ (defun ,(alexandria:symbolicate name '-using-types) ,lambda-list

+ ,@body))))