(let ((cv-ks (cv (kpd.ks pd))))
(funcall reduce-fn d-rbds)))))
+281: COMPUTE-EFFECTIVE-METHOD error signalling.
+ (slightly obscured by a non-0 default value for
+ SB-PCL::*MAX-EMF-PRECOMPUTE-METHODS*)
+ It would be natural for COMPUTE-EFFECTIVE-METHOD to signal errors
+ when it finds a method with invalid qualifiers. However, it
+ shouldn't signal errors when any such methods are not applicable to
+ the particular call being evaluated, and certainly it shouldn't when
+ simply precomputing effective methods that may never be called.
+ (setf sb-pcl::*max-emf-precompute-methods* 0)
+ (defgeneric foo (x)
+ (:method-combination +)
+ (:method ((x symbol)) 1)
+ (:method + ((x number)) x))
+ (foo 1) -> ERROR, but should simply return 1
+
+ The issue seems to be that construction of a discriminating function
+ calls COMPUTE-EFFECTIVE-METHOD with methods that are not all applicable.
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
He has contributed a number of bug fixes and bug reports to SBCL.
Brian Mastenbrook:
- He contributed to the port of SBCL to MacOS X.
+ He contributed to the port of SBCL to MacOS X. He found a way to
+ overcome binary compatibility issues between different versions of
+ dlcompat on Darwin.
Dave McDonald:
He made a lot of progress toward getting SBCL to be bootstrappable
Debian packages of SBCL.
Christophe Rhodes:
- He ported SBCL to SPARC, made various port-related and SPARC-related
- changes (like *BACKEND-SUBFEATURES*), made many fixes and
- improvements in the compiler's type system, has essentially
- completed the work to enable bootstrapping SBCL under unrelated
- (non-SBCL, non-CMU-CL) Common Lisps, and contributed in other ways
- as well.
+ He ported SBCL to SPARC (based on the CMUCL backend), made various
+ port-related and SPARC-related changes (like *BACKEND-SUBFEATURES*),
+ made many fixes and improvements in the compiler's type system, has
+ essentially completed the work to enable bootstrapping SBCL under
+ unrelated (non-SBCL, non-CMU-CL) Common Lisps. He participated in
+ the modernization of SBCL's CLOS implementation, implemented the
+ treatment of compiler notes as restartable conditions, provided
+ optimizations to compiler output, and contributed in other ways as
+ well.
Stig Erik Sandoe:
He showed how to convince the GNU toolchain to build SBCL in a way
changes in sbcl-0.8.4 relative to sbcl-0.8.3:
* fixed compiler performance when processing loops with a step >1;
+ * optimization: restored some effective method precomputation
+ (turned off by an ANSI fix in sbcl-0.8.3); the amount of
+ precomputation is now tunable.
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
~I~_when called with arguments ~2I~_~S.~:>"
generic-function
args))
+
+(defmethod invalid-qualifiers ((gf generic-function)
+ combin
+ method)
+ (let ((qualifiers (method-qualifiers method)))
+ (let ((why (cond
+ ((cdr qualifiers) "has too many qualifiers")
+ (t (aver (not (member (car qualifiers)
+ '(:around :before :after))))
+ "has an invalid qualifier"))))
+ (invalid-method-error
+ method
+ "The method ~S on ~S ~A.~%~
+ Standard method combination requires all methods to have one~%~
+ of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
+ have no qualifier at all."
+ method gf why))))
(get-generic-fun-info gf)
(declare (ignore nreq nkeys arg-info))
(let ((ll (make-fast-method-call-lambda-list metatypes applyp))
- (error-p (eq (first effective-method) '%no-primary-method))
+ (error-p (or (eq (first effective-method) '%no-primary-method)
+ (eq (first effective-method) '%invalid-qualifiers)))
(mc-args-p
(when (eq *boot-state* 'complete)
;; Otherwise the METHOD-COMBINATION slot is not bound.
(error-p
`(lambda (.pv-cell. .next-method-call. &rest .args.)
(declare (ignore .pv-cell. .next-method-call.))
+ (declare (ignorable .args.))
(flet ((%no-primary-method (gf args)
- (apply #'no-primary-method gf args)))
+ (apply #'no-primary-method gf args))
+ (%invalid-qualifiers (gf combin method)
+ (invalid-qualifiers gf combin method)))
+ (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
,effective-method)))
(mc-args-p
(let* ((required
`(call-method-list
,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
-(defun standard-compute-effective-method (generic-function combin applicable-methods)
- (declare (ignore combin))
- (let ((before ())
- (primary ())
- (after ())
- (around ()))
- (flet ((lose (method why)
- (invalid-method-error
- method
- "The method ~S ~A.~%~
- Standard method combination requires all methods to have one~%~
- of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
- have no qualifier at all."
- method why)))
+(defun standard-compute-effective-method
+ (generic-function combin applicable-methods)
+ (collect ((before) (primary) (after) (around))
+ (flet ((invalid (gf combin m)
+ (if *in-precompute-effective-methods-p*
+ (return-from standard-compute-effective-method
+ `(%invalid-qualifiers ',gf ',combin ',m))
+ (invalid-qualifiers gf combin m))))
(dolist (m applicable-methods)
- (let ((qualifiers (if (listp m)
- (early-method-qualifiers m)
- (method-qualifiers m))))
- (cond
- ((null qualifiers) (push m primary))
- ((cdr qualifiers)
- (lose m "has more than one qualifier"))
- ((eq (car qualifiers) :around)
- (push m around))
- ((eq (car qualifiers) :before)
- (push m before))
- ((eq (car qualifiers) :after)
- (push m after))
- (t
- (lose m "has an illegal qualifier"))))))
- (setq before (reverse before)
- after (reverse after)
- primary (reverse primary)
- around (reverse around))
- (cond ((null primary)
+ (let ((qualifiers (if (listp m)
+ (early-method-qualifiers m)
+ (method-qualifiers m))))
+ (cond
+ ((null qualifiers) (primary m))
+ ((cdr qualifiers) (invalid generic-function combin m))
+ ((eq (car qualifiers) :around) (around m))
+ ((eq (car qualifiers) :before) (before m))
+ ((eq (car qualifiers) :after) (after m))
+ (t (invalid generic-function combin m))))))
+ (cond ((null (primary))
`(%no-primary-method ',generic-function .args.))
- ((and (null before) (null after) (null around))
+ ((and (null (before)) (null (after)) (null (around)))
;; By returning a single call-method `form' here we enable
;; an important implementation-specific optimization.
- `(call-method ,(first primary) ,(rest primary)))
+ `(call-method ,(first (primary)) ,(rest (primary))))
(t
(let ((main-effective-method
- (if (or before after)
+ (if (or (before) (after))
`(multiple-value-prog1
(progn
- ,(make-call-methods before)
- (call-method ,(first primary)
- ,(rest primary)))
- ,(make-call-methods (reverse after)))
- `(call-method ,(first primary) ,(rest primary)))))
- (if around
- `(call-method ,(first around)
- (,@(rest around)
+ ,(make-call-methods (before))
+ (call-method ,(first (primary))
+ ,(rest (primary))))
+ ,(make-call-methods (reverse (after))))
+ `(call-method ,(first (primary)) ,(rest (primary))))))
+ (if (around)
+ `(call-method ,(first (around))
+ (,@(rest (around))
(make-method ,main-effective-method)))
main-effective-method))))))
\f
applicable-methods))
(defun invalid-method-error (method format-control &rest format-arguments)
- (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
- method
- format-control
- format-arguments))
+ (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+ (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
+ method
+ format-control
+ format-arguments)))
(defun method-combination-error (format-control &rest format-arguments)
- (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
- format-control
- format-arguments))
+ (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+ (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
+ format-control
+ format-arguments)))
(order (car (method-combination-options combin)))
(around ())
(primary ()))
- (dolist (m applicable-methods)
- (let ((qualifiers (method-qualifiers m)))
- (flet ((lose (method why)
- (invalid-method-error
- method
- "The method ~S ~A.~%~
- The method combination type ~S was defined with the~%~
- short form of DEFINE-METHOD-COMBINATION and so requires~%~
- all methods have either the single qualifier ~S or the~%~
- single qualifier :AROUND."
- method why type type)))
- (cond ((null qualifiers)
- (lose m "has no qualifiers"))
- ((cdr qualifiers)
- (lose m "has more than one qualifier"))
+ (flet ((invalid (gf combin m)
+ (if *in-precompute-effective-methods-p*
+ (return-from compute-effective-method
+ `(%invalid-qualifiers ',gf ',combin ',m))
+ (invalid-qualifiers gf combin m))))
+ (dolist (m applicable-methods)
+ (let ((qualifiers (method-qualifiers m)))
+ (cond ((null qualifiers) (invalid generic-function combin m))
+ ((cdr qualifiers) (invalid generic-function combin m))
((eq (car qualifiers) :around)
(push m around))
((eq (car qualifiers) type)
(push m primary))
- (t
- (lose m "has an illegal qualifier"))))))
+ (t (invalid generic-function combin m))))))
(setq around (nreverse around))
(ecase order
(:most-specific-last) ; nothing to be done, already in correct order
(t
`(call-method ,(car around)
(,@(cdr around) (make-method ,main-method))))))))
+
+(defmethod invalid-qualifiers ((gf generic-function)
+ (combin short-method-combination)
+ method)
+ (let ((qualifiers (method-qualifiers method))
+ (type (method-combination-type combin)))
+ (let ((why (cond
+ ((null qualifiers) "has no qualifiers")
+ ((cdr qualifiers) "has too many qualifiers")
+ (t (aver (and (neq (car qualifiers) type)
+ (neq (car qualifiers) :around)))
+ "has an invalid qualifier"))))
+ (invalid-method-error
+ method
+ "The method ~S on ~S ~A.~%~
+ The method combination type ~S was defined with the~%~
+ short form of DEFINE-METHOD-COMBINATION and so requires~%~
+ all methods have either the single qualifier ~S or the~%~
+ single qualifier :AROUND."
+ method gf why type type))))
\f
;;;; long method combinations
(return (nconc (frob required nr nreq)
(frob optional no nopt)
values)))))
+
;;; considered as state transitions.
(defvar *lazy-dfun-compute-p* t)
(defvar *early-p* nil)
-(defvar *max-emf-precomputation-methods* 0)
+(defvar *max-emf-precomputation-methods* 10)
(defun finalize-specializers (gf)
(let ((methods (generic-function-methods gf)))
- (when (< (length methods) *max-emf-precomputation-methods*)
+ (when (<= (length methods) *max-emf-precomputation-methods*)
(let ((all-finalized t))
(dolist (method methods all-finalized)
(dolist (specializer (method-specializers method))
(defgeneric find-method-combination (generic-function type options))
+(defgeneric invalid-qualifiers (generic-function combin method))
+
(defgeneric (setf slot-accessor-function) (function slotd type))
(defgeneric (setf slot-accessor-std-p) (value slotd type))
;;; with something arbitrary in the fourth field, is used for CVS
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
-"0.8.3.3"
+"0.8.3.4"
projects / sbcl.git / commitdiff