X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=c4494e6dae6cba52e1729aae0f8b88ead56a0f4d;hb=227096b878fee7afae9d3bc2cee5df01449bca2d;hp=395d32fa6b5be8f66968ec7d1ea824ec07436640;hpb=6ff8c9d8fa5770038489d40d1993c7a1156b9811;p=sbcl.git diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 395d32f..c4494e6 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -174,13 +174,43 @@ (get-generic-fun-info gf) (declare (ignore nreq nkeys arg-info)) (let ((ll (make-fast-method-call-lambda-list metatypes applyp)) - ;; When there are no primary methods and a next-method call occurs - ;; effective-method is (error "No mumble..") and the defined - ;; args are not used giving a compiler warning. - (error-p (eq (first effective-method) 'error))) - `(lambda ,ll - (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.)))) - ,effective-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. + (let ((combin (generic-function-method-combination gf))) + (and (long-method-combination-p combin) + (long-method-combination-args-lambda-list combin)))))) + (cond + (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)) + (%invalid-qualifiers (gf combin method) + (invalid-qualifiers gf combin method))) + (declare (ignorable #'%no-primary-method #'%invalid-qualifiers)) + ,effective-method))) + (mc-args-p + (let* ((required + ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp + (let (req) + (dotimes (i (length metatypes) (nreverse req)) + (push (dfun-arg-symbol i) req)))) + (gf-args (if applyp + `(list* ,@required .dfun-rest-arg.) + `(list ,@required)))) + `(lambda ,ll + (declare (ignore .pv-cell. .next-method-call.)) + (let ((.gf-args. ,gf-args)) + (declare (ignorable .gf-args.)) + ,effective-method)))) + (t + `(lambda ,ll + (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.)))) + ,effective-method)))))) (defun expand-emf-call-method (gf form metatypes applyp env) (declare (ignore gf metatypes applyp env)) @@ -306,60 +336,44 @@ `(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) - `(error "There is no primary method for the generic function ~S." - ',generic-function)) - ((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))) + (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))) + ;; By returning a single call-method `form' here we enable + ;; an important implementation-specific optimization. + `(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)))))) @@ -381,12 +395,14 @@ applicable-methods)) (defun invalid-method-error (method format-control &rest format-arguments) - (error "~@" - method - format-control - format-arguments)) + (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (error "~@" + method + format-control + format-arguments))) (defun method-combination-error (format-control &rest format-arguments) - (error "~@" - format-control - format-arguments)) + (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (error "~@" + format-control + format-arguments)))