diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index bb078952d..404bd9d27 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -196,10 +196,19 @@ ;;; ---------------------------------------------------------------------- ;;; COMPUTE-APPLICABLE-METHODS ;;; -;;; FIXME! This should be split int an internal function, like -;;; raw-compute-... and a higher level interface, because the current -;;; version does not check _any_ of the arguments but it is -;;; nevertheless exported by the ANSI specification! +;;; This part is a source of problems because we have to access slots of +;;; various objects, which could potentially lead to infinite recursion as +;;; those accessors require also some dispatch. The solution is to avoid +;;; calling then generic function that implement the accessors. +;;; This is possible because: +;;; 1. The user can only extend compute-applicable-methods if it +;;; defines a method with a subclass of standard-generic-function +;;; 2. The user cannot extend slot-value and friends on standard-classes +;;; due to the restriction "Any method defined by a portable program +;;; on a specified generic function must have at least one specializer +;;; that is neither a specified class nor an eql specializer whose +;;; associated value is an instance of a specified class." +;;; 3. Subclasses of specified classes preserve the slot order in ECL. ;;; (defun std-compute-applicable-methods (gf args) (sort-applicable-methods gf (applicable-method-list gf args) args)) @@ -209,76 +218,73 @@ (defun applicable-method-list (gf args) (declare (optimize (speed 3)) (si::c-local)) - (flet ((applicable-method-p (method args) - #+(or) - (print `(= ,(mapcar #'class-id (mapcar #'class-of args)) - ,(mapcar #'class-id (method-specializers method)))) - (loop for spec in (method-specializers method) - for arg in args - 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))) + (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+) + (flet ((applicable-method-p (method args) + (loop for spec in (method-specializers method) + for arg in args + 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)))) (defun std-compute-applicable-methods-using-classes (gf classes) (declare (optimize (speed 3))) - (flet ((applicable-method-p (method classes) - (loop for spec in (method-specializers method) - for class in classes - always (cond ((eql-specializer-flag spec) - ;; EQL specializer invalidate computation - ;; we return NIL - (when (si::of-class-p (eql-specializer-object spec) class) - (return-from std-compute-applicable-methods-using-classes - (values nil nil))) - nil) - ((si::subclassp class spec)))))) - (values (sort-applicable-methods - gf - (loop for method in (generic-function-methods gf) - when (applicable-method-p method classes) - collect method) - classes) - t))) + (with-early-accessors (+standard-method-slots+ +eql-specializer-slots+ +standard-generic-function-slots+) + (flet ((applicable-method-p (method classes) + (loop for spec in (method-specializers method) + for class in classes + always (cond ((eql-specializer-flag spec) + ;; EQL specializer invalidate computation + ;; we return NIL + (when (si::of-class-p (eql-specializer-object spec) class) + (return-from std-compute-applicable-methods-using-classes + (values nil nil))) + nil) + ((si::subclassp class spec)))))) + (values (sort-applicable-methods + gf + (loop for method in (generic-function-methods gf) + when (applicable-method-p method classes) + collect method) + classes) + t)))) (defun sort-applicable-methods (gf applicable-list args) (declare (optimize (safety 0) (speed 3))) - #+(or) - (unless applicable-list - (print (generic-function-name gf)) - (print (mapcar #'type-of args))) - (let ((f (generic-function-a-p-o-function gf)) - (args-specializers (mapcar #'class-of args))) - ;; reorder args to match the precedence order - (when f - (setf args-specializers - (funcall f (subseq args-specializers 0 - (length (generic-function-argument-precedence-order gf)))))) - ;; then order the list - (do* ((scan applicable-list) - (most-specific (first scan) (first scan)) - (ordered-list)) - ((null (cdr scan)) - (when most-specific - ;; at least one method - (nreverse - (push most-specific ordered-list)))) - (dolist (meth (cdr scan)) - (when (eq (compare-methods most-specific - meth args-specializers f) 2) - (setq most-specific meth))) - (setq scan (delete most-specific scan)) - (push most-specific ordered-list)))) + (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+) + (let ((f (generic-function-a-p-o-function gf)) + (args-specializers (mapcar #'class-of args))) + ;; reorder args to match the precedence order + (when f + (setf args-specializers + (funcall f (subseq args-specializers 0 + (length (generic-function-argument-precedence-order gf)))))) + ;; then order the list + (do* ((scan applicable-list) + (most-specific (first scan) (first scan)) + (ordered-list)) + ((null (cdr scan)) + (when most-specific + ;; at least one method + (nreverse + (push most-specific ordered-list)))) + (dolist (meth (cdr scan)) + (when (eq (compare-methods most-specific + meth args-specializers f) 2) + (setq most-specific meth))) + (setq scan (delete most-specific scan)) + (push most-specific ordered-list))))) (defun compare-methods (method-1 method-2 args-specializers f) (declare (si::c-local)) - (let* ((specializers-list-1 (method-specializers method-1)) - (specializers-list-2 (method-specializers method-2))) - (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1) - (if f (funcall f specializers-list-2) specializers-list-2) - args-specializers))) + (with-early-accessors (+standard-method-slots+) + (let* ((specializers-list-1 (method-specializers method-1)) + (specializers-list-2 (method-specializers method-2))) + (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1) + (if f (funcall f specializers-list-2) specializers-list-2) + args-specializers)))) (defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers) (declare (si::c-local)) @@ -304,83 +310,77 @@ (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) - ;; There is only one class with a single element, which - ;; is NULL = (MEMBER NIL). - (and (null (second spec2)) - (eq (class-name spec1) 'null))) - (if (atom spec2) - (si::of-class-p (second spec1) spec2) - (eql (second spec1) (second spec2))))) + (with-early-accessors (+eql-specializer-slots+ +standard-class-slots+) + (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))))) (defun compare-specializers (spec-1 spec-2 arg-class) (declare (si::c-local)) - (let* ((cpl (class-precedence-list arg-class))) - (cond ((eq spec-1 spec-2) '=) - ((fast-subtypep spec-1 spec-2) '1) - ((fast-subtypep spec-2 spec-1) '2) - ((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 - (t nil)))) + (with-early-accessors (+standard-class-slots+ +standard-class-slots+) + (let* ((cpl (class-precedence-list arg-class))) + (cond ((eq spec-1 spec-2) '=) + ((fast-subtypep spec-1 spec-2) '1) + ((fast-subtypep spec-2 spec-1) '2) + ((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 + (t nil))))) (defun compute-g-f-spec-list (gf) - (flet ((nupdate-spec-how-list (spec-how-list specializers gf) - ;; 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) - (spec-how-old)) - ((null l)) - (setq spec-how (first l) spec-how-old (first l2)) - (setf (first l2) - (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 - spec-how)))) - spec-how-list)) - (let* ((spec-how-list nil) - (function nil) - (a-p-o (generic-function-argument-precedence-order gf))) - (dolist (method (generic-function-methods gf)) - (setf spec-how-list - (nupdate-spec-how-list spec-how-list (method-specializers method) gf))) - (setf (generic-function-spec-list gf) - (loop for type in spec-how-list - for i from 0 - when type collect (cons type i))) - (let* ((g-f-l-l (generic-function-lambda-list gf))) - (when (consp g-f-l-l) - (let ((required-arguments (rest (si::process-lambda-list g-f-l-l t)))) - (unless (equal a-p-o required-arguments) - (setf function - (coerce `(lambda (%list) - (destructuring-bind ,required-arguments %list - (list ,@a-p-o))) - 'function)))))) - (setf (generic-function-a-p-o-function gf) function) - (si:clear-gfun-hash gf)))) + (with-early-accessors (+standard-generic-function-slots+ + +eql-specializer-slots+ + +standard-method-slots+) + (flet ((nupdate-spec-how-list (spec-how-list specializers gf) + ;; 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) + (spec-how-old)) + ((null l)) + (setq spec-how (first l) spec-how-old (first l2)) + (setf (first l2) + (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 + spec-how)))) + spec-how-list)) + (let* ((spec-how-list nil) + (function nil) + (a-p-o (generic-function-argument-precedence-order gf))) + (dolist (method (generic-function-methods gf)) + (setf spec-how-list + (nupdate-spec-how-list spec-how-list (method-specializers method) gf))) + (setf (generic-function-spec-list gf) + (loop for type in spec-how-list + for i from 0 + when type collect (cons type i))) + (let* ((g-f-l-l (generic-function-lambda-list gf))) + (when (consp g-f-l-l) + (let ((required-arguments (rest (si::process-lambda-list g-f-l-l t)))) + (unless (equal a-p-o required-arguments) + (setf function + (coerce `(lambda (%list) + (destructuring-bind ,required-arguments %list + (list ,@a-p-o))) + 'function)))))) + (setf (generic-function-a-p-o-function gf) function) + (si:clear-gfun-hash gf))))) (defun print-object (object stream) (print-unreadable-object (object stream)))