mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 23:32:17 -08:00
The dispatch protocol for generic functions no longer uses generic functions for accessing slots. The comments explain why.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
ed78ecd2ea
commit
53ffe3dd40
1 changed files with 137 additions and 137 deletions
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue