diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index a1c1205e6..6b063f79a 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -30,6 +30,9 @@ (class-default-initargs class) nil (class-precedence-list class) nil (class-finalized-p class) t + (eql-specializer-flag class) nil + (specializer-direct-methods class) nil + (specializer-direct-generic-functions class) nil (find-class name) class) (unless (eq name 'T) (setf (slot-table class) (make-hash-table :size 2))) @@ -71,6 +74,12 @@ ;; hash table for them, so that SLOT-VALUE works. Notice that we ;; make a intentional mistake: CLASS and STANDARD-CLASS share the same ;; hashtable!! + (do* ((i 0 (1+ i)) + (slots eql-specializer-slots (cdr slots))) + ((endp slots)) + (let ((slotd (first slots))) + (setf (slot-definition-location slotd) i) + (setf (gethash (slot-definition-name slotd) hash-table) slotd))) (do* ((i 0 (1+ i)) (slots standard-slots (cdr slots))) ((endp slots)) @@ -80,6 +89,9 @@ (dolist (slotd class-slots) (setf (slot-definition-location slotd) (slot-definition-location (gethash (slot-definition-name slotd) hash-table)))) + (dolist (slotd specializer-slots) + (setf (slot-definition-location slotd) + (slot-definition-location (gethash (slot-definition-name slotd) hash-table)))) (setf (class-slots the-class) (copy-list class-slots) (class-size the-class) (length class-slots) (slot-table the-class) hash-table @@ -261,8 +273,7 @@ ;; shared slot (car location)) (t - (error "Effective slot definition lacks a valid location:~%~A" - slotd))))) + (invalid-slot-definition instance slotd))))) (defun standard-instance-set (val instance slotd) (ensure-up-to-date-instance instance) @@ -275,9 +286,14 @@ ;; shared slot (setf (car location) val)) (t - (error "Effective slot definition lacks a valid location:~%~A" - slotd))) - val)) + (invalid-slot-definition instance slotd)))) + val) + +(defun invalid-slot-definition (instance slotd) + (error "Effective slot definition lacks a valid location. +Class name: ~A +Slot name: ~A" + (type-of instance) (slot-definition-name slotd))) (defmethod slot-value-using-class ((class class) self slotd) (let ((value (standard-instance-get self slotd))) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 191019ef3..be90bfdab 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -262,6 +262,8 @@ their lambda lists ~A and ~A are not congruent." ;;; Error messages (defmethod no-applicable-method (gf args) + (print (generic-function-name gf)) + (print (mapcar #'type-of args)) (error "No applicable method for ~S with arguments of types~{~& ~A~}" (generic-function-name gf) (mapcar #'type-of args))) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 031d25b10..d9681ae46 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -63,11 +63,11 @@ (eval-when (compile eval) (defparameter +specializer-slots+ - '((flag :initform nil :accessor specializer-flag) + '((flag :initform nil :accessor eql-specializer-flag) (direct-methods :initform nil :accessor specializer-direct-methods) (direct-generic-functions :initform nil :accessor specializer-direct-generic-functions))) (defparameter +eql-specializer-slots+ - '((flag :initform t :accessor specializer-flag) + '((flag :initform t :accessor eql-specializer-flag) (direct-methods :initform nil :accessor specializer-direct-methods) (direct-generic-functions :initform nil :accessor specializer-direct-generic-functions) (object :initarg :object :accessor eql-specializer-object)))) @@ -222,7 +222,7 @@ ; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) (let* ((gf (ensure-generic-function name)) (specializers (mapcar #'(lambda (x) - (cond ((consp x) x) + (cond ((consp x) (intern-eql-specializer (second x))) ((typep x 'specializer) x) ((find-class x nil)) (t @@ -273,9 +273,7 @@ ((not (eq common-class class)) (return t))) do (loop for spec in specializers - unless (or (eq spec t) - (null spec) - (eq spec +the-t-class+) + unless (or (eq spec +the-t-class+) (and (si::instancep spec) (eq (si::instance-class spec) +the-standard-class+))) @@ -289,7 +287,7 @@ (t (return t)))))) (set-funcallable-instance-function gfun (gf-type gfun)))) - + ;;; ---------------------------------------------------------------------- @@ -311,11 +309,9 @@ (flet ((applicable-method-p (method args) (loop for spec in (method-specializers method) for arg in args - always (cond ((null spec) t) - ((listp spec) - ;; EQL specializer - (eql arg (second spec))) - ((si::of-class-p arg spec)))))) + always (if (eql-specializer-flag spec) + (eql arg (eql-specializer-object spec)) + (si::of-class-p arg spec))))) (loop for method in (generic-function-methods gf) when (applicable-method-p method args) collect method))) @@ -325,11 +321,10 @@ (flet ((applicable-method-p (method classes) (loop for spec in (method-specializers method) for class in classes - always (cond ((null spec)) - ((listp spec) + always (cond ((eql-specializer-flag spec) ;; EQL specializer invalidate computation ;; we return NIL - (when (si::of-class-p (second spec) class) + (when (si::of-class-p (eql-specializer-object spec) class) (return-from std-compute-applicable-methods-using-classes (values nil nil))) nil) @@ -399,6 +394,18 @@ (declare (si::c-local)) ;; Specialized version of subtypep which uses the fact that spec1 ;; and spec2 are either classes or of the form (EQL x) + (if (eql-specializer-flag spec1) + (if (eql-specializer-flag spec2) + (eql (eql-specializer-object spec1) + (eql-specializer-object spec2)) + (si::of-class-p (eql-specializer-object spec1) spec2)) + (if (eql-specializer-flag spec2) + ;; There is only one class with a single element, which + ;; is NULL = (MEMBER NIL). + (and (null (eql-specializer-object spec2)) + (eq (class-name spec1) 'null)) + (si::subclassp spec1 spec2))) + #+(or) (if (atom spec1) (if (atom spec2) (si::subclassp spec1 spec2) @@ -413,13 +420,11 @@ (defun compare-specializers (spec-1 spec-2 arg-class) (declare (si::c-local)) (let* ((cpl (class-precedence-list arg-class))) - (cond ((equal spec-1 spec-2) '=) - ((null spec-1) '2) - ((null spec-2) '1) + (cond ((eq spec-1 spec-2) '=) ((fast-subtypep spec-1 spec-2) '1) ((fast-subtypep spec-2 spec-1) '2) - ((and (listp spec-1) (eq (car spec-1) 'eql)) '1) ; is this engough? - ((and (listp spec-2) (eq (car spec-2) 'eql)) '2) ; Beppe + ((eql-specializer-flag spec-1) '1) ; is this engough? + ((eql-specializer-flag spec-2) '2) ; Beppe ((member spec-1 (member spec-2 cpl)) '2) ((member spec-2 (member spec-1 cpl)) '1) ;; This will force an error in the caller @@ -427,15 +432,10 @@ (defun compute-g-f-spec-list (gf) (flet ((nupdate-spec-how-list (spec-how-list specializers gf) - ;; FIXME! This check should have happened before, shouldn't it??? - (let ((l (length specializers))) - (if spec-how-list - (unless (= (length spec-how-list) l) - (error "The generic function ~A~%has ~D required arguments, but the new specialization provides ~D." - gf (length spec-how-list) l)) - (setf spec-how-list (make-list l)))) ;; update the spec-how of the gfun ;; computing the or of the previous value and the new one + (setf spec-how-list (or spec-how-list + (copy-list specializers))) (do* ((l specializers (cdr l)) (l2 spec-how-list (cdr l2)) (spec-how) @@ -443,13 +443,12 @@ ((null l)) (setq spec-how (first l) spec-how-old (first l2)) (setf (first l2) - (if (consp spec-how) ; an eql list - (if (consp spec-how-old) - (list* (second spec-how) spec-how-old) - (cdr spec-how)) + (if (eql-specializer-flag spec-how) + (list* (eql-specializer-object spec-how) + (and (consp spec-how-old) spec-how-old)) (if (consp spec-how-old) spec-how-old - (or spec-how spec-how-old))))) + spec-how)))) spec-how-list)) (let* ((spec-how-list nil) (function nil) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 80e6948ad..7f3894d54 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -334,25 +334,43 @@ have disappeared." (defun find-method (gf qualifiers specializers &optional (errorp t)) (declare (notinline method-qualifiers)) - (let* ((method-list (generic-function-methods gf)) - found) - (dolist (method method-list) - (when (and (equal qualifiers (method-qualifiers method)) - (equal specializers (method-specializers method))) - (return-from find-method method))) + (flet ((filter-specializer (name) + (cond ((typep name 'specializer) + name) + ((atom name) + (let ((class (find-class name nil))) + (unless class + (error "~A is not a valid specializer name" name)) + class)) + ((and (eq (first name) 'EQL) + (null (cddr name))) + (cdr name)) + (t + (error "~A is not a valid specializer name" name)))) + (specializer= (cons-or-class specializer) + (if (consp cons-or-class) + (and (eql-specializer-flag specializer) + (eql (car cons-or-class) + (eql-specializer-object specializer))) + (eq cons-or-class specializer)))) + (when (/= (length specializers) + (length (generic-function-argument-precedence-order gf))) + (error + "The specializers list~%~A~%does not match the number of required arguments in ~A" + specializers (generic-function-name gf))) + (loop with specializers = (mapcar #'filter-specializer specializers) + for method in (generic-function-methods gf) + when (and (equal qualifiers (method-qualifiers method)) + (every #'specializer= specializers (method-specializers method))) + do (return-from find-method method)) ;; If we did not find any matching method, then the list of ;; specializers might have the wrong size and we must signal ;; an error. - (cond ((/= (length specializers) - (length (generic-function-argument-precedence-order gf))) - (error - "The specializers list~%~A~%does not match the number of required arguments in ~A" - specializers (generic-function-name gf))) - (errorp - (error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S" - (generic-function-name gf) - qualifiers specializers))) - nil)) + (when errorp + (error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S" + (generic-function-name gf) + qualifiers specializers))) + nil) ;;; ---------------------------------------------------------------------- diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index bb354b9f4..1b3204bea 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -63,16 +63,29 @@ (lambda-list nil lambda-supplied-p) generic-function) (declare (ignore initargs method slot-names)) - (unless spec-supplied-p - (error "Specializer list not supplied in method initialization")) - (unless lambda-supplied-p - (error "Lambda list not supplied in method initialization")) - (unless (= (first (si::process-lambda-list lambda-list 'method)) - (length specializers)) - (error "The list of specializers does not match the number of required arguments in the lambda list ~A" - lambda-list)) - (loop for s in specializers - unless (or (typep s 'specializer) - (consp s)) - do (error "Object ~A is not a valid specializer" s)) + (when slot-names + (unless spec-supplied-p + (error "Specializer list not supplied in method initialization")) + (unless lambda-supplied-p + (error "Lambda list not supplied in method initialization")) + (unless (= (first (si::process-lambda-list lambda-list 'method)) + (length specializers)) + (error "The list of specializers does not match the number of required arguments in the lambda list ~A" + lambda-list))) + (when spec-supplied-p + (loop for s in specializers + unless (typep s 'specializer) + do (error "Object ~A is not a valid specializer" s))) (add-method-keywords (call-next-method))) + +#+threads +(defparameter *eql-specializer-lock* (mp:make-lock :name 'eql-specializer)) +(defparameter *eql-specializer-hash* + (make-hash-table :size 128 :test #'eql)) + +(defun intern-eql-specializer (object) + (let ((table *eql-specializer-hash*)) + (mp:with-lock (*eql-specializer-lock*) + (or (gethash object table nil) + (setf (gethash object table) + (make-instance 'eql-specializer :object object))))))