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

* Prepare for overload resolution at compile time

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

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

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

+ :alexandria

- [_$_]

-

- :type string))

+ :type string

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

-#|

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

- (name gf) (rest args))))

- (if (static-p method)

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

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

-|#

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

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

+#|

+|#

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

+ (multiple-value-bind (method sequence)

- (mapcar #'(lambda (a)

- (let ((type (type-of a)))

- (if (subtypep type 'smoke-standard-object)

- (class-of a)

- type)))

- arguments)

+ arguments

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

-; (when (stack-p type)

-; (add-object ret))

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

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

+

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

+

+#|

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

+|#

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

- [_$_]

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

- ; :id ,(id class)

- ; :smoke ,smoke)

- ; ,method-name args)))

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

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

-

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

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

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

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

+(defun internal-p (method)

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

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

+

+ ((cffi:pointerp lisp-value)

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

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

- `(integer ,lower ,upper))

-

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

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

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

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

+that accept ARGUMENT-COUNT arguments."

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

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

- ()

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

+ :initarg :conversion-function-name))

-(defclass no-match (std-conversion)

- ((rank :reader rank

- :allocation :class

- :initform +no-match+)))

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

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

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

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

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

+ t)

+ "Returns the greater conversion of CONVERSION1 and CONVERSION2."

+

+(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 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+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 standard-conversion-sequence-using-classes (method classes &optional user)

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

- ;(format t "~A~%~3T~A~%" method classes)

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

- (push function conversions)))

+ (push (conversion-function-name rank) 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)

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

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

+ (best-rank)

- (funcall get-sequence method classes)

+ (funcall get-sequence method objects)

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

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

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

+ (values best-method conversions)))

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

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

- [_$_]

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

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

- ;(values boolean (or nil function)))

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

+ object)

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

- (mapcar #'funcall sequence args)))

+ (mapcar #'(lambda (conversion argument)

+ (funcall conversion argument))

+ sequence args)))

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

+ (multiple-value-bind (method sequence)

- (mapcar #'(lambda (a)

- (let ((type (type-of a)))

- (if (subtypep type 'smoke-standard-object)

- (class-of a)

- type)))

- arguments)

+ arguments

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

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

+

+

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

+)

-

- (intern (format nil "UINT~A" (* 8

- (smoke-sizeof-bool)))

- ; (foreign-funcall smoke-sizeof-bool :int)))

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

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

+ "Smoke index."

+ `(integer ,lower ,upper))

+

-#|

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

-|#

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