Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cache overload resolution on sbcl

--- old-smoke/src/overload-resolution.lisp 2014-10-30 08:06:14.000000000 +0100

+++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:06:14.000000000 +0100

@@ -195,24 +195,27 @@

conversion2

conversion1)))

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

- `(,(symbolicate 'make- (eval type))

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

- ,@args))

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

+ (if arg

+ `(if (using-typep)

+ `(,,name

+ ,(if (typep ,arg 'class)

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

+ `(find-smoke-method (find-class ,(class-name

+ (find-smoke-class

+ (get-class ,arg))))

+ ,(name ,arg))))

+ #'(lambda (object)

+ (funcall (fdefinition ,name)

+ object ,arg)))

+ `(if (using-typep)

+ ,name

+ (fdefinition ,name)))))

+ `(,(symbolicate 'make- (eval type))

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

+ ,@args)))

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

"Retrains a conversion sequence to convert a instance of type CLASS

@@ -304,7 +307,11 @@

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

#'(lambda (type type-p)

(and (if type-p

- (subtypep type ',lisp-type)

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

+ (subtypep type ',lisp-type)

+ (unless valid-p

+ (throw 'unspecific-type type))

+ value)

(typep type ',lisp-type))

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

@@ -337,8 +344,10 @@

(9 (object.typep '(c-integer :unsigned-long)))

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

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

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

- (smoke-type= type (enum-type object))))

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

+ (when (using-typep)

+ (throw 'unspecific-type object))

+ (smoke-type= type (enum-type object))))

(13 (and (object.typep 'smoke-standard-object)

(smoke-type= (get-class type) (object.type-of))))))

@@ -518,18 +527,21 @@

(type (or smoke-standard-class smoke-standard-object)

object-or-class))

(multiple-value-bind (method sequence)

- (find-best-viable-function name

- arguments

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

- (when (typep object-or-class

- 'smoke-standard-object)

- (const-p object-or-class)))

+ (#-sbcl find-best-viable-function

+ #+sbcl find-best-viable-function-cached

+ name

+ arguments

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

+ (when (typep object-or-class

+ 'smoke-standard-object)

+ (const-p object-or-class)))

(when (null method)

(error (make-condition 'no-applicable-cxx-method

:method name

:class object-or-class

:arguments arguments)))

- (if (static-p method)

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

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

- sequence arguments))))

+ (apply #'call-sequence method

+ (if (static-p method)

+ (null-pointer)

+ (cast object-or-class (get-class method)))

+ sequence arguments)))