X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=ecda4e673ed468d919605e4bd1be1a93f66111ae;hb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;hp=6163057f1dfe62c92bc93a7e06bad7874c85eb93;hpb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 6163057..ecda4e6 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -25,10 +25,13 @@ (defmacro define-method-combination (&whole form &rest args) (declare (ignore args)) - (if (and (cddr form) - (listp (caddr form))) - (expand-long-defcombin form) - (expand-short-defcombin form))) + `(progn + (with-single-package-locked-error + (:symbol ',(second form) "defining ~A as a method combination")) + ,(if (and (cddr form) + (listp (caddr form))) + (expand-long-defcombin form) + (expand-short-defcombin form)))) ;;;; standard method combination @@ -130,10 +133,8 @@ (around ()) (primary ())) (flet ((invalid (gf combin m) - (if *in-precompute-effective-methods-p* - (return-from compute-effective-method - `(%invalid-qualifiers ',gf ',combin ',m)) - (invalid-qualifiers gf combin m)))) + (return-from compute-effective-method + `(%invalid-qualifiers ',gf ',combin ',m)))) (dolist (m applicable-methods) (let ((qualifiers (method-qualifiers m))) (cond ((null qualifiers) (invalid generic-function combin m)) @@ -296,59 +297,82 @@ .method-combination. .applicable-methods.)) (block .long-method-combination-function. ,wrapped-body)))))) -;; parse-method-group-specifiers parse the method-group-specifiers +(define-condition long-method-combination-error + (reference-condition simple-error) + () + (:default-initargs + :references (list '(:ansi-cl :macro define-method-combination)))) + +;;; NOTE: +;;; +;;; The semantics of long form method combination in the presence of +;;; multiple methods with the same specializers in the same method +;;; group are unclear by the spec: a portion of the standard implies +;;; that an error should be signalled, and another is more lenient. +;;; +;;; It is reasonable to allow a single method group of * to bypass all +;;; rules, as this is explicitly stated in the standard. + +(defun group-cond-clause (name tests specializer-cache star-only) + (let ((maybe-error-clause + (if star-only + `(setq ,specializer-cache .specializers.) + `(if (and (equal ,specializer-cache .specializers.) + (not (null .specializers.))) + (return-from .long-method-combination-function. + '(error 'long-method-combination-error + :format-control "More than one method of type ~S ~ + with the same specializers." + :format-arguments (list ',name))) + (setq ,specializer-cache .specializers.))))) + `((or ,@tests) + ,maybe-error-clause + (push .method. ,name)))) (defun wrap-method-group-specifier-bindings - (method-group-specifiers declarations real-body) - (let (names - specializer-caches - cond-clauses - required-checks - order-cleanups) + (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) - (multiple-value-bind (name tests description order required) - (parse-method-group-specifier method-group-specifier) - (declare (ignore description)) - (let ((specializer-cache (gensym))) - (push name names) - (push specializer-cache specializer-caches) - (push `((or ,@tests) - (if (and (equal ,specializer-cache .specializers.) - (not (null .specializers.))) - (return-from .long-method-combination-function. - '(error "More than one method of type ~S ~ - with the same specializers." - ',name)) - (setq ,specializer-cache .specializers.)) - (push .method. ,name)) - cond-clauses) - (when required - (push `(when (null ,name) - (return-from .long-method-combination-function. - '(error "No ~S methods." ',name))) - required-checks)) - (loop (unless (and (constantp order) - (neq order (setq order (eval order)))) - (return t))) - (push (cond ((eq order :most-specific-first) - `(setq ,name (nreverse ,name))) - ((eq order :most-specific-last) ()) - (t - `(ecase ,order - (:most-specific-first - (setq ,name (nreverse ,name))) - (:most-specific-last)))) - order-cleanups)))) - `(let (,@(nreverse names) ,@(nreverse specializer-caches)) - ,@declarations - (dolist (.method. .applicable-methods.) - (let ((.qualifiers. (method-qualifiers .method.)) - (.specializers. (method-specializers .method.))) - (declare (ignorable .qualifiers. .specializers.)) - (cond ,@(nreverse cond-clauses)))) - ,@(nreverse required-checks) - ,@(nreverse order-cleanups) - ,@real-body))) + (multiple-value-bind (name tests description order required) + (parse-method-group-specifier method-group-specifier) + (declare (ignore description)) + (let ((specializer-cache (gensym))) + (push name names) + (push specializer-cache specializer-caches) + (push (group-cond-clause name tests specializer-cache + (and (eq (cadr method-group-specifier) '*) + (= nspecifiers 1))) + cond-clauses) + (when required + (push `(when (null ,name) + (return-from .long-method-combination-function. + '(error 'long-method-combination-error + :format-control "No ~S methods." + :format-arguments (list ',name)))) + required-checks)) + (loop (unless (and (constantp order) + (neq order (setq order (eval order)))) + (return t))) + (push (cond ((eq order :most-specific-first) + `(setq ,name (nreverse ,name))) + ((eq order :most-specific-last) ()) + (t + `(ecase ,order + (:most-specific-first + (setq ,name (nreverse ,name))) + (:most-specific-last)))) + order-cleanups)))) + `(let (,@(nreverse names) ,@(nreverse specializer-caches)) + ,@declarations + (dolist (.method. .applicable-methods.) + (let ((.qualifiers. (method-qualifiers .method.)) + (.specializers. (method-specializers .method.))) + (declare (ignorable .qualifiers. .specializers.)) + (cond ,@(nreverse cond-clauses)))) + ,@(nreverse required-checks) + ,@(nreverse order-cleanups) + ,@real-body)))) (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) @@ -409,12 +433,21 @@ ;;; ;;; At compute-effective-method time, the symbols in the :arguments ;;; option are bound to the symbols in the intercept lambda list. +;;; +;;; FIXME: in here we have not one but two mini-copies of a weird +;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST. (defun deal-with-args-option (wrapped-body args-lambda-list) (let ((intercept-rebindings (let (rebindings) (dolist (arg args-lambda-list (nreverse rebindings)) (unless (member arg lambda-list-keywords) - (push `(,arg ',arg) rebindings))))) + (typecase arg + (symbol (push `(,arg ',arg) rebindings)) + (cons + (unless (symbolp (car arg)) + (error "invalid lambda-list specifier: ~S." arg)) + (push `(,(car arg) ',(car arg)) rebindings)) + (t (error "invalid lambda-list-specifier: ~S." arg))))))) (nreq 0) (nopt 0) (whole nil))