X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=5be842e33e28c6aaff308cf562d7111d7b9a1823;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=610011ba4cd4ec3e8dead76b6c98b03add21fca0;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 610011b..5be842e 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -60,7 +60,7 @@ (make-effective-method-function-simple generic-function form) ;; We have some sort of `real' effective method. Go off and get a ;; compiled function for it. Most of the real hair here is done by - ;; the GET-FUNCTION mechanism. + ;; the GET-FUN mechanism. (make-effective-method-function-internal generic-function form method-alist-p wrappers-p))) @@ -74,7 +74,7 @@ (method (car cm-args))) (when method (if (if (listp method) - (eq (car method) ':early-method) + (eq (car method) :early-method) (method-p method)) (if method-alist-p t @@ -95,7 +95,7 @@ (defun make-effective-method-function-simple (generic-function form &optional no-fmf-p) - ;; The effective method is just a call to call-method. This opens up + ;; The effective method is just a call to CALL-METHOD. This opens up ;; the possibility of just using the method function of the method as ;; the effective method function. ;; @@ -129,7 +129,7 @@ gf (car next-methods) (list* (cdr next-methods) (cdr cm-args)) fmf-p method-alist wrappers)) - (arg-info (method-function-get fmf ':arg-info))) + (arg-info (method-function-get fmf :arg-info))) (make-fast-method-call :function fmf :pv-cell pv-cell :next-method-call next @@ -143,7 +143,7 @@ (gf method cm-args fmf-p &optional method-alist wrappers) (when method (if (if (listp method) - (eq (car method) ':early-method) + (eq (car method) :early-method) (method-p method)) (make-emf-from-method method cm-args gf fmf-p method-alist wrappers) (if (and (consp method) (eq (car method) 'make-method)) @@ -171,16 +171,41 @@ (defun expand-effective-method-function (gf effective-method &optional env) (declare (ignore env)) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) - (get-generic-function-info gf) + (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)) @@ -255,7 +280,7 @@ (defun make-effective-method-function-internal (generic-function effective-method method-alist-p wrappers-p) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) - (get-generic-function-info generic-function) + (get-generic-fun-info generic-function) (declare (ignore nkeys arg-info)) (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) @@ -266,16 +291,16 @@ (effective-method-lambda (expand-effective-method-function generic-function effective-method))) (multiple-value-bind (cfunction constants) - (get-function1 effective-method-lambda - (lambda (form) - (memf-test-converter form generic-function - method-alist-p wrappers-p)) - (lambda (form) - (memf-code-converter form generic-function - metatypes applyp - method-alist-p wrappers-p)) - (lambda (form) - (memf-constant-converter form generic-function))) + (get-fun1 effective-method-lambda + (lambda (form) + (memf-test-converter form generic-function + method-alist-p wrappers-p)) + (lambda (form) + (memf-code-converter form generic-function + metatypes applyp + method-alist-p wrappers-p)) + (lambda (form) + (memf-constant-converter form generic-function))) (lambda (method-alist wrappers) (let* ((constants (mapcar (lambda (constant) @@ -341,19 +366,19 @@ 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. + ;; 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) `(multiple-value-prog1 - (progn ,(make-call-methods before) - (call-method ,(first primary) - ,(rest primary))) + (progn + ,(make-call-methods before) + (call-method ,(first primary) + ,(rest primary))) ,(make-call-methods (reverse after))) `(call-method ,(first primary) ,(rest primary))))) (if around