diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 4735fb5a8..a0b9b2ed2 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -28,7 +28,7 @@ ;;; name to class. ;;; ;;; This is only used during boot. The real one is in built-in. -(eval-when (compile) +(eval-when (:compile-toplevel) (defun setf-find-class (new-value class &optional errorp env) (warn "Ignoring class definition for ~S" class))) @@ -65,7 +65,7 @@ (defun install-method (name qualifiers specializers lambda-list fun &rest options) (declare (notinline ensure-generic-function)) -; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) + ;;(record-definition 'method `(method ,name ,@qualifiers ,specializers)) (let* ((gf (ensure-generic-function name)) (fun (wrapped-method-function fun)) (specializers (mapcar #'(lambda (x) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 5f6fcda3f..12765e48f 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -47,6 +47,19 @@ (when *clos-booted* (class-prototype (generic-function-method-class generic-function)))) +(defun prototypes-for-make-method-lambda (name) + (if (not *clos-booted*) + (values nil nil) + (let ((gf? (and (fboundp name) + (fdefinition name)))) + (if (or (null gf?) + (not (si:instancep gf?))) + (values (class-prototype (find-class 'standard-generic-function)) + (class-prototype (find-class 'standard-method))) + (values gf? + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method)))))))) + (defmacro defmethod (&whole whole name &rest args &environment env) (declare (notinline make-method-lambda)) (multiple-value-bind (qualifiers specialized-lambda-list body) @@ -55,10 +68,10 @@ (parse-specialized-lambda-list specialized-lambda-list) (multiple-value-bind (lambda-form declarations documentation) (make-raw-lambda name lambda-list required-parameters specializers body env) - (let* ((generic-function (ensure-generic-function name)) - (method (method-prototype-for-gf generic-function))) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda name) (multiple-value-bind (fn-form options) - (make-method-lambda generic-function method lambda-form env) + (make-method-lambda proto-gf proto-method lambda-form env) (when documentation (setf options (list* :documentation documentation options))) (ext:register-with-pde diff --git a/src/tests/normal-tests/metaobject-protocol.lsp b/src/tests/normal-tests/metaobject-protocol.lsp index 10460c83d..c7b7efcd6 100644 --- a/src/tests/normal-tests/metaobject-protocol.lsp +++ b/src/tests/normal-tests/metaobject-protocol.lsp @@ -661,6 +661,6 @@ the metaclass") (ext:with-clean-symbols (foo1 foo2) (test mop.0024.frc (finishes (defclass foo1 (foo2) ())) - (signals (make-instance 'foo1)) - (finishes (defclass foo2 (foo) ())) + (signals error (make-instance 'foo1)) + (finishes (defclass foo2 () ())) (finishes (make-instance 'foo1))))