X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=c4dc44981d0e36f208ef310bc5b3d4a95f4115f0;hb=HEAD;hp=21e886f2c8b8dc668690d8ca3142c93308106585;hpb=2375dc21aed5764dc2ecbccdd6665d6db0596731;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 21e886f..c4dc449 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -42,11 +42,11 @@ ;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping ;;; reasons. (defmethod find-method-combination ((generic-function generic-function) - (type (eql 'standard)) + (type-name (eql 'standard)) options) (when options (method-combination-error - "The method combination type STANDARD accepts no options.")) + "STANDARD method combination accepts no options.")) *standard-method-combination*) ;;;; short method combinations @@ -56,31 +56,22 @@ ;;;; method combination object just reads the parameters out of the object ;;;; and runs the same rule. -(defclass short-method-combination (standard-method-combination) - ((operator - :reader short-combination-operator - :initarg :operator) - (identity-with-one-argument - :reader short-combination-identity-with-one-argument - :initarg :identity-with-one-argument)) - (:predicate-name short-method-combination-p)) - (defun expand-short-defcombin (whole) - (let* ((type (cadr whole)) + (let* ((type-name (cadr whole)) (documentation (getf (cddr whole) :documentation)) (identity-with-one-arg (getf (cddr whole) :identity-with-one-argument nil)) (operator - (getf (cddr whole) :operator type))) + (getf (cddr whole) :operator type-name))) `(load-short-defcombin - ',type ',operator ',identity-with-one-arg ',documentation + ',type-name ',operator ',identity-with-one-arg ',documentation (sb-c:source-location)))) -(defun load-short-defcombin (type operator ioa doc source-location) +(defun load-short-defcombin (type-name operator ioa doc source-location) (let* ((specializers (list (find-class 'generic-function) - (intern-eql-specializer type) + (intern-eql-specializer type-name) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) @@ -89,23 +80,23 @@ (make-instance 'standard-method :qualifiers () :specializers specializers - :lambda-list '(generic-function type options) + :lambda-list '(generic-function type-name options) :function (lambda (args nms &rest cm-args) (declare (ignore nms cm-args)) (apply - (lambda (gf type options) + (lambda (gf type-name options) (declare (ignore gf)) (short-combine-methods - type options operator ioa new-method doc)) + type-name options operator ioa new-method doc)) args)) :definition-source source-location)) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) - (setf (random-documentation type 'method-combination) doc) - type)) + (setf (random-documentation type-name 'method-combination) doc) + type-name)) -(defun short-combine-methods (type options operator ioa method doc) +(defun short-combine-methods (type-name options operator ioa method doc) (cond ((null options) (setq options '(:most-specific-first))) ((equal options '(:most-specific-first))) ((equal options '(:most-specific-last))) @@ -114,9 +105,9 @@ "Illegal options to a short method combination type.~%~ The method combination type ~S accepts one option which~%~ must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." - type))) + type-name))) (make-instance 'short-method-combination - :type type + :type-name type-name :options options :operator operator :identity-with-one-argument ioa @@ -126,7 +117,7 @@ (defmethod compute-effective-method ((generic-function generic-function) (combin short-method-combination) applicable-methods) - (let ((type (method-combination-type combin)) + (let ((type-name (method-combination-type-name combin)) (operator (short-combination-operator combin)) (ioa (short-combination-identity-with-one-argument combin)) (order (car (method-combination-options combin))) @@ -141,7 +132,7 @@ ((cdr qualifiers) (invalid generic-function combin m)) ((eq (car qualifiers) :around) (push m around)) - ((eq (car qualifiers) type) + ((eq (car qualifiers) type-name) (push m primary)) (t (invalid generic-function combin m)))))) (setq around (nreverse around)) @@ -192,11 +183,11 @@ (combin short-method-combination) method) (let ((qualifiers (method-qualifiers method)) - (type (method-combination-type combin))) + (type-name (method-combination-type-name combin))) (let ((why (cond ((null qualifiers) "has no qualifiers") ((cdr qualifiers) "has too many qualifiers") - (t (aver (and (neq (car qualifiers) type) + (t (aver (and (neq (car qualifiers) type-name) (neq (car qualifiers) :around))) "has an invalid qualifier")))) (invalid-method-error @@ -206,12 +197,12 @@ 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)))) + method gf why type-name type-name)))) ;;;; long method combinations (defun expand-long-defcombin (form) - (let ((type (cadr form)) + (let ((type-name (cadr form)) (lambda-list (caddr form)) (method-group-specifiers (cadddr form)) (body (cddddr form)) @@ -223,17 +214,18 @@ (setq gf-var (cadr (pop body)))) (multiple-value-bind (documentation function) (make-long-method-combination-function - type lambda-list method-group-specifiers args-option gf-var + type-name lambda-list method-group-specifiers args-option gf-var body) - `(load-long-defcombin ',type ',documentation #',function + `(load-long-defcombin ',type-name ',documentation #',function ',args-option (sb-c:source-location))))) (defvar *long-method-combination-functions* (make-hash-table :test 'eq)) -(defun load-long-defcombin (type doc function args-lambda-list source-location) +(defun load-long-defcombin + (type-name doc function args-lambda-list source-location) (let* ((specializers (list (find-class 'generic-function) - (intern-eql-specializer type) + (intern-eql-specializer type-name) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) @@ -241,37 +233,37 @@ (make-instance 'standard-method :qualifiers () :specializers specializers - :lambda-list '(generic-function type options) + :lambda-list '(generic-function type-name options) :function (lambda (args nms &rest cm-args) (declare (ignore nms cm-args)) (apply - (lambda (generic-function type options) + (lambda (generic-function type-name options) (declare (ignore generic-function)) (make-instance 'long-method-combination - :type type + :type-name type-name :options options :args-lambda-list args-lambda-list :documentation doc)) args)) :definition-source source-location))) - (setf (gethash type *long-method-combination-functions*) function) + (setf (gethash type-name *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) - (setf (random-documentation type 'method-combination) doc) - type)) + (setf (random-documentation type-name 'method-combination) doc) + type-name)) (defmethod compute-effective-method ((generic-function generic-function) (combin long-method-combination) applicable-methods) - (funcall (gethash (method-combination-type combin) + (funcall (gethash (method-combination-type-name combin) *long-method-combination-functions*) generic-function combin applicable-methods)) (defun make-long-method-combination-function - (type ll method-group-specifiers args-option gf-var body) - (declare (ignore type)) + (type-name ll method-group-specifiers args-option gf-var body) + (declare (ignore type-name)) (multiple-value-bind (real-body declarations documentation) (parse-body body) (let ((wrapped-body @@ -332,7 +324,12 @@ (method-group-specifiers declarations real-body) (let (names specializer-caches cond-clauses required-checks order-cleanups) (let ((nspecifiers (length method-group-specifiers))) - (dolist (method-group-specifier method-group-specifiers) + (dolist (method-group-specifier method-group-specifiers + (push `(t (return-from .long-method-combination-function. + `(invalid-method-error , .method. + "~@"))) + cond-clauses)) (multiple-value-bind (name tests description order required) (parse-method-group-specifier method-group-specifier) (declare (ignore description)) @@ -351,7 +348,8 @@ :format-arguments (list ',name)))) required-checks)) (loop (unless (and (constantp order) - (neq order (setq order (eval order)))) + (neq order (setq order + (constant-form-value order)))) (return t))) (push (cond ((eq order :most-specific-first) `(setq ,name (nreverse ,name))) @@ -439,7 +437,7 @@ (let ((intercept-rebindings (let (rebindings) (dolist (arg args-lambda-list (nreverse rebindings)) - (unless (member arg lambda-list-keywords) + (unless (member arg lambda-list-keywords :test #'eq) (typecase arg (symbol (push `(,arg ',arg) rebindings)) (cons