Sun Jan 10 18:31:42 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix overload resolution when a lisp smoke module is not loaded.

--- old-smoke/cl-smoke.smoke.asd 2014-10-30 07:05:35.000000000 +0100

+++ new-smoke/cl-smoke.smoke.asd 2014-10-30 07:05:35.000000000 +0100

@@ -54,9 +54,6 @@

#+(not (or sbcl openmcl))

(:file "not-implemented")))))))))))

-(defmethod operation-done-p ((o test-op) (c (eql (find-system :cl-smoke.smoke))))

- nil)

-

(defmethod perform ((operation test-op) (c (eql (find-system :cl-smoke.smoke))))

(operate 'asdf:load-op :cl-smoke.qt.tests)

(operate 'asdf:test-op :cl-smoke.qt.tests))

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

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

@@ -70,6 +70,12 @@

(slot-value condition 'smoke-name))))

(:documentation "A undefined Smoke class"))

+(define-condition lisp-module-not-loaded (error)

+ ((class-name :initarg :class-name))

+ (:report (lambda (condition stream)

+ (format stream "The Lisp smoke module of the class ~A is not loaded."

+ (slot-value condition 'class-name)))))

+

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

@@ -84,9 +90,16 @@

:report "Supply a new class name"

:interactive read-new-value

(setf name new-name))))

- (make-instance 'smoke-class

- :id (foreign-slot-value c 'smoke-module-index 'index)

- :smoke (gethash (pointer-address (foreign-slot-value c 'smoke-module-index 'smoke)) *smoke-modules*))))

+ (let ((class (make-instance

+ 'smoke-class

+ :id (foreign-slot-value c 'smoke-module-index 'index)

+ :smoke (gethash (pointer-address (foreign-slot-value

+ c 'smoke-module-index

+ 'smoke))

+ *smoke-modules*))))

+ (unless (smoke class)

+ (error (make-condition 'lisp-module-not-loaded :class-name name)))

+ class)))

(defun real-class (class)

"Returns the same class like CLASS, but such that EXTERNAL-P returns NIL."

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

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

@@ -463,17 +463,21 @@

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

(when (class-p type)

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

- (when (and to-class

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

- (if (using-typep)

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

- #'standard-conversion-sequence)

- (constructor-name (get-class type))

- (list object) to-class))

- (make-match 'user-conversion

- 'coerce-to-class

- to-class)))))

+ (handler-case

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

+ (when (and to-class

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

+ (if (using-typep)

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

+ #'standard-conversion-sequence)

+ (constructor-name (get-class type))

+ (list object) to-class))

+ (make-match 'user-conversion

+ 'coerce-to-class

+ to-class)))

+ ;; When the correspoinding Lisp module is not loaded, we ignore

+ ;; the overload.

+ (lisp-module-not-loaded ()))))

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

(s-call method object