X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=3429ad7da885f6288871d979052cf6eab348a799;hb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;hp=d04a904a014bf11a50b268c055880dd9d3905860;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index d04a904..3429ad7 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -60,22 +60,24 @@ (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))) -(defun make-effective-method-function-type (generic-function form - method-alist-p wrappers-p) +(defun make-effective-method-fun-type (generic-function + form + method-alist-p + wrappers-p) (if (and (listp form) (eq (car form) 'call-method)) (let* ((cm-args (cdr form)) (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 + t (multiple-value-bind (mf fmf) (if (listp method) (early-method-function method) @@ -86,14 +88,14 @@ 'fast-method-call 'method-call)))) (if (and (consp method) (eq (car method) 'make-method)) - (make-effective-method-function-type + (make-effective-method-fun-type generic-function (cadr method) method-alist-p wrappers-p) (type-of method))))) 'fast-method-call)) (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. ;; @@ -109,9 +111,13 @@ (null (cddr cm-args)))) (method (car cm-args)) (cm-args1 (cdr cm-args))) - #'(lambda (method-alist wrappers) - (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p - method-alist wrappers)))) + (lambda (method-alist wrappers) + (make-effective-method-function-simple1 generic-function + method + cm-args1 + fmf-p + method-alist + wrappers)))) (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) @@ -123,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 @@ -137,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)) @@ -165,7 +171,7 @@ (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 @@ -173,8 +179,8 @@ ;; 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)))) + (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)) @@ -186,21 +192,21 @@ (defun memf-test-converter (form generic-function method-alist-p wrappers-p) (cond ((and (consp form) (eq (car form) 'call-method)) - (case (make-effective-method-function-type + (case (make-effective-method-fun-type generic-function form method-alist-p wrappers-p) (fast-method-call '.fast-call-method.) (t '.call-method.))) ((and (consp form) (eq (car form) 'call-method-list)) - (case (if (every #'(lambda (form) - (eq 'fast-method-call - (make-effective-method-function-type - generic-function form - method-alist-p wrappers-p))) + (case (if (every (lambda (form) + (eq 'fast-method-call + (make-effective-method-fun-type + generic-function form + method-alist-p wrappers-p))) (cdr form)) 'fast-method-call - 't) + t) (fast-method-call '.fast-call-method-list.) (t @@ -213,19 +219,19 @@ (cond ((and (consp form) (eq (car form) 'call-method)) (let ((gensym (get-effective-method-gensym))) (values (make-emf-call metatypes applyp gensym - (make-effective-method-function-type + (make-effective-method-fun-type generic-function form method-alist-p wrappers-p)) (list gensym)))) ((and (consp form) (eq (car form) 'call-method-list)) (let ((gensym (get-effective-method-gensym)) - (type (if (every #'(lambda (form) - (eq 'fast-method-call - (make-effective-method-function-type - generic-function form - method-alist-p wrappers-p))) + (type (if (every (lambda (form) + (eq 'fast-method-call + (make-effective-method-fun-type + generic-function form + method-alist-p wrappers-p))) (cdr form)) 'fast-method-call - 't))) + t))) (values `(dolist (emf ,gensym nil) ,(make-emf-call metatypes applyp 'emf type)) (list gensym)))) @@ -239,9 +245,9 @@ generic-function form)))) ((and (consp form) (eq (car form) 'call-method-list)) (list (cons '.meth-list. - (mapcar #'(lambda (form) - (make-effective-method-function-simple - generic-function form)) + (mapcar (lambda (form) + (make-effective-method-function-simple + generic-function form)) (cdr form))))) (t (default-constant-converter form)))) @@ -249,56 +255,56 @@ (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*) (name (if (early-gf-p generic-function) - (early-gf-name generic-function) + (!early-gf-name generic-function) (generic-function-name generic-function))) (arg-info (cons nreq applyp)) (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))) - #'(lambda (method-alist wrappers) - (let* ((constants - (mapcar #'(lambda (constant) - (if (consp constant) - (case (car constant) - (.meth. - (funcall (cdr constant) - method-alist wrappers)) - (.meth-list. - (mapcar #'(lambda (fn) - (funcall fn - method-alist - wrappers)) - (cdr constant))) - (t constant)) - constant)) - constants)) - (function (set-function-name - (apply cfunction constants) - `(combined-method ,name)))) - (make-fast-method-call :function function - :arg-info arg-info))))))) + (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) + (if (consp constant) + (case (car constant) + (.meth. + (funcall (cdr constant) + method-alist wrappers)) + (.meth-list. + (mapcar (lambda (fn) + (funcall fn + method-alist + wrappers)) + (cdr constant))) + (t constant)) + constant)) + constants)) + (function (set-fun-name + (apply cfunction constants) + `(combined-method ,name)))) + (make-fast-method-call :function function + :arg-info arg-info))))))) (defmacro call-method-list (&rest calls) `(progn ,@calls)) (defun make-call-methods (methods) `(call-method-list - ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods))) + ,@(mapcar (lambda (method) `(call-method ,method ())) methods))) (defun standard-compute-effective-method (generic-function combin applicable-methods) (declare (ignore combin)) @@ -306,15 +312,30 @@ (primary ()) (after ()) (around ())) - (dolist (m applicable-methods) - (let ((qualifiers (if (listp m) - (early-method-qualifiers m) - (method-qualifiers m)))) - (cond ((member ':before qualifiers) (push m before)) - ((member ':after qualifiers) (push m after)) - ((member ':around qualifiers) (push m around)) - (t - (push m primary))))) + (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))) + (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) @@ -341,67 +362,30 @@ (make-method ,main-effective-method))) main-effective-method)))))) -;;;; the STANDARD method combination type. This is coded by hand (rather than -;;;; with define-method-combination) for bootstrapping and efficiency reasons. -;;;; Note that the definition of the find-method-combination-method appears in -;;;; the file defcombin.lisp. This is because EQL methods can't appear in the +;;;; the STANDARD method combination type. This is coded by hand +;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping +;;;; and efficiency reasons. Note that the definition of the +;;;; FIND-METHOD-COMBINATION-METHOD appears in the file +;;;; defcombin.lisp. This is because EQL methods can't appear in the ;;;; bootstrap. ;;;; -;;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION -;;;; classes has to appear here for this reason. This code must conform to -;;;; the code in the file defcombin.lisp, look there for more details. +;;;; The DEFCLASS for the METHOD-COMBINATION and +;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this +;;;; reason. This code must conform to the code in the file +;;;; defcombin.lisp, look there for more details. (defun compute-effective-method (generic-function combin applicable-methods) (standard-compute-effective-method generic-function combin applicable-methods)) -(defvar *invalid-method-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) +(defun invalid-method-error (method format-control &rest format-arguments) + (error "~@" + method + format-control + format-arguments)) -(defvar *method-combination-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) - -;(defmethod compute-effective-method :around ;issue with magic -; ((generic-function generic-function) ;generic functions -; (method-combination method-combination) -; applicable-methods) -; (declare (ignore applicable-methods)) -; (flet ((real-invalid-method-error (method format-string &rest args) -; (declare (ignore method)) -; (apply #'error format-string args)) -; (real-method-combination-error (format-string &rest args) -; (apply #'error format-string args))) -; (let ((*invalid-method-error* #'real-invalid-method-error) -; (*method-combination-error* #'real-method-combination-error)) -; (call-next-method)))) - -(defun invalid-method-error (&rest args) - (declare (arglist method format-string &rest format-arguments)) - (apply *invalid-method-error* args)) - -(defun method-combination-error (&rest args) - (declare (arglist format-string &rest format-arguments)) - (apply *method-combination-error* args)) - -;This definition now appears in defcombin.lisp. -; -;(defmethod find-method-combination ((generic-function generic-function) -; (type (eql 'standard)) -; options) -; (when options -; (method-combination-error -; "The method combination type STANDARD accepts no options.")) -; *standard-method-combination*) +(defun method-combination-error (format-control &rest format-arguments) + (error "~@" + format-control + format-arguments))