X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=5be842e33e28c6aaff308cf562d7111d7b9a1823;hb=22aec7852f4861e5dab28cc0d619c24b62590dad;hp=47b78446c99352969bde5b23591da34fdfcc3480;hpb=f1924827a97ecd2249209344c03b73b15200cc37;p=sbcl.git diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 47b7844..5be842e 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -174,13 +174,38 @@ (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 (eq (first effective-method) '%no-primary-method)) + (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.)) + (flet ((%no-primary-method (gf args) + (apply #'no-primary-method gf args))) + ,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)) @@ -341,8 +366,7 @@ primary (reverse primary) around (reverse around)) (cond ((null primary) - `(error "There is no primary method for the generic function ~S." - ',generic-function)) + `(%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.