Mon May 11 13:07:39 CEST 2009 Tobias Rautenkranz * Prepare for overload resolution at compile time diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd --- old-smoke/smoke.mbd 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/smoke.mbd 2014-10-01 19:31:59.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)) diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-01 19:31:59.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)) diff -rN -u old-smoke/src/cxx-method.lisp new-smoke/src/cxx-method.lisp --- old-smoke/src/cxx-method.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/cxx-method.lisp 2014-10-01 19:31:59.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))) +|# diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp --- old-smoke/src/method.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/method.lisp 2014-10-01 19:31:59.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))) diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp --- old-smoke/src/object-map.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/object-map.lisp 2014-10-01 19:31:59.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) diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp --- old-smoke/src/objects/method.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/objects/method.lisp 2014-10-01 19:31:59.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) diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp --- old-smoke/src/objects/stack.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/objects/stack.lisp 2014-10-01 19:31:59.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) diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp --- old-smoke/src/overload-resolution.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/overload-resolution.lisp 2014-10-01 19:31:59.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) +) diff -rN -u old-smoke/src/smoke-c/class.lisp new-smoke/src/smoke-c/class.lisp --- old-smoke/src/smoke-c/class.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/smoke-c/class.lisp 2014-10-01 19:31:59.000000000 +0200 @@ -7,7 +7,6 @@ (:virtual-destructor #x04) (:undefined #x10)) - (defcstruct smoke-class "Describe a class" (name :string) 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-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/smoke-c/smoke-c.lisp 2014-10-01 19:31:59.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) diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2014-10-01 19:31:59.000000000 +0200 +++ new-smoke/src/smoke.lisp 2014-10-01 19:31:59.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) diff -rN -u old-smoke/src/using-type.lisp new-smoke/src/using-type.lisp --- old-smoke/src/using-type.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/using-type.lisp 2014-10-01 19:31:59.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))))