common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Accept :ORDER NIL in long-form method-combination group specifiers

Browse source 
This allows the programmer to explicitly annotate that the order of
the methods in the method group does not matter (for example, because
they are ordered explicitly by the method combination body), and
therefore that the matching of methods to groups should not throw an
error if there are multiple methods with the same specializers.

This is (strictly speaking) a violation of the specification, which
requires that the only acceptable arguments to :ORDER should be
:MOST-SPECIFIC-FIRST and :MOST-SPECIFIC-LAST.  Document this violation
in the manual.
This commit is contained in:
Christophe Rhodes 2023-01-31 09:08:33 +00:00
parent 4f597a3c6d
commit 65082b4d78
5 changed files with 107 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
NEWS
View file

@ -1,6 +1,11 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-2.3.1:
* incompatible change: the :ORDER long-form-option in
DEFINE-METHOD-COMBINATION accepts NIL as well as :MOST-SPECIFIC-FIRST and
:MOST-SPECIFIC-LAST. A value of NIL implies no particular ordering of the
methods, and so disables checks of multiple methods with the same
specializers in that group.
* bug fix: evaluate the :ORDER long-form-option in DEFINE-METHOD-COMBINATION
properly, avoiding an infinite loop in DEFINE-METHOD-COMBINATION if the
:ORDER argument leads to a cycle of compile-time constants.

9
doc/manual/intro.texinfo
View file

@ -48,6 +48,15 @@ The @code{string} type is considered to be the union of all types
@code{(array @emph{c} (@emph{size}))} for all non-@code{nil} subtypes @code{@emph{c}} of
@code{character}, excluding arrays specialized to the empty type.
@item
@findex @cl{define-method-combination}
@vindex @cl{nil}
The @code{:order} long form option in @code{define-method-combination}
method group specifiers accepts the value @code{nil} as well as
@code{:most-specific-first} and @code{:most-specific-last}, in order
to allow programmers to declare that the order of methods playing that
role in the method combination does not matter.
@end itemize
@node Extensions

74
src/pcl/defcombin.lisp
View file

@ -263,22 +263,17 @@
;;; 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)
(defun group-cond-clause (name tests specializer-cache order-matters-test)
(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 ~
`(if (and ,order-matters-test
(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.)))))
:format-arguments (list ',name)))
(setq ,specializer-cache .specializers.))))
`((or ,@tests)
,maybe-error-clause
(push .method. ,name))))
@ -296,13 +291,33 @@
(multiple-value-bind (name tests description order required)
(parse-method-group-specifier method-group-specifier)
(declare (ignore description))
(let ((specializer-cache (gensym)))
(let* ((specializer-cache (gensym))
(order-var (gensym "O"))
(order-constantp (constantp order))
(order-value (and order-constantp (constant-form-value order))))
(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)
(unless order-constantp
(push `(,order-var ,order) order-vars))
(let ((order-matters-test
(cond
;; It is reasonable to allow a single method
;; group of * to bypass all rules, as this is
;; explicitly stated in the standard.
((and (eq (cadr method-group-specifier) '*)
(= nspecifiers 1))
nil)
;; an :ORDER value known at compile-time to be
;; NIL (an SBCL extension) also bypasses the
;; ordering checks. (Other :ORDER values do
;; not.)
(order-constantp (not (eql order-value nil)))
;; otherwise, check the ORDER value at
;; method-combination time, bypassing ordering
;; checks if it is NIL.
(t `(not (eql ,order-var nil))))))
(push (group-cond-clause name tests specializer-cache order-matters-test)
cond-clauses))
(when required
(push `(when (null ,name)
(return-from .long-method-combination-function.
@ -310,18 +325,15 @@
:format-control "No ~S methods."
:format-arguments (list ',name))))
required-checks))
(let* ((order-constantp (and (constantp order)))
(order-value (and order-constantp (constant-form-value order))))
(cond
((and order-constantp (eq order-value :most-specific-first))
(push `(setq ,name (nreverse ,name)) order-cleanups))
((and order-constantp (eq order-value :most-specific-last)))
(t (let ((order-var (gensym "O")))
(push `(ecase ,order-var
(:most-specific-first (setq ,name (nreverse ,name)))
(:most-specific-last))
order-cleanups)
(push `(,order-var ,order) order-vars))))))))
(cond
((and order-constantp (eq order-value :most-specific-first))
(push `(setq ,name (nreverse ,name)) order-cleanups))
((and order-constantp
(or (null order-value) (eq order-value :most-specific-last))))
(t (push `(ecase ,order-var
(:most-specific-first (setq ,name (nreverse ,name)))
((nil :most-specific-last)))
order-cleanups))))))
`(let (,@(nreverse names) ,@specializer-caches ,@order-vars)
(declare (ignorable ,@specializer-caches))
,@declarations

46
tests/clos-1.impure.lisp
View file

@ -361,3 +361,49 @@
(:method-combination dont-overevaluate)
(:method ((x t)) x))
(assert-error (dont-overevaluate-gf 1)))
;;; An example (non-normative) from the Standard, which we interpret
;;; as failing the requirement not to have multiple methods with the
;;; same specializers in the same method group.
(defun positive-integer-qualifier-p (method-qualifiers)
(and (= (length method-qualifiers) 1)
(typep (first method-qualifiers) '(integer 0 *))))
(define-method-combination example-method-combination ()
((methods positive-integer-qualifier-p))
`(progn ,@(mapcar #'(lambda (method)
`(call-method ,method))
(stable-sort methods #'<
:key #'(lambda (method)
(first (method-qualifiers method)))))))
(defgeneric example-method-combination-gf (x s)
(:method-combination example-method-combination)
(:method 1 (x (s stream)) (format s "~&1: ~A~%" x))
(:method 2 (x (s stream)) (format s "~&2: ~A~%" x)))
(with-test (:name :clhs-example-method-combination-no-order)
(assert-error (example-method-combination-gf 1 (make-broadcast-stream))))
;;; The same example as above, modified to declare (using a
;;; non-standard extension) that the order it receives methods in the
;;; group does not matter.
(define-method-combination example-method-combination-order-nil ()
((methods positive-integer-qualifier-p :order nil))
`(progn ,@(mapcar #'(lambda (method)
`(call-method ,method))
(stable-sort methods #'<
:key #'(lambda (method)
(first (method-qualifiers method)))))))
(defgeneric example-method-combination-order-nil-gf (x s)
(:method-combination example-method-combination-order-nil)
(:method 1 (x (s stream)) (format s "1: ~A and " x))
(:method 2 (x (s stream)) (format s "2: ~A" x)))
(with-test (:name :clhs-example-method-combination-order-nil)
(let ((string (with-output-to-string (s)
(example-method-combination-order-nil-gf t s))))
(assert (string= string "1: T and 2: T"))))

8
tests/clos.impure.lisp
View file

@ -814,11 +814,11 @@
(assert (= (wam-test-mc-b 13) 13))
(defmethod wam-test-mc-b :around ((val number))
(+ val (if (next-method-p) (call-next-method) 0)))
(assert (= (wam-test-mc-b 13) 26))
(assert (= (wam-test-mc-b 14) 28))
(defmethod wam-test-mc-b :somethingelse ((val number))
(+ val (if (next-method-p) (call-next-method) 0)))
(let ((*error-output* (make-broadcast-stream)))
(assert-error (wam-test-mc-b 13)))
(assert-error (wam-test-mc-b 15)))
;;; now, ensure that it fails with a single group with a qualifier-pattern
;;; that is not *
@ -833,11 +833,11 @@
(assert-error (wam-test-mc-c 13))
(defmethod wam-test-mc-c :foo ((val number))
(+ val (if (next-method-p) (call-next-method) 0)))
(assert (= (wam-test-mc-c 13) 13))
(assert (= (wam-test-mc-c 14) 14))
(defmethod wam-test-mc-c :bar ((val number))
(+ val (if (next-method-p) (call-next-method) 0)))
(let ((*error-output* (make-broadcast-stream)))
(assert-error (wam-test-mc-c 13)))
(assert-error (wam-test-mc-c 15)))
;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
;;; given: