Fix multi-arity dispatch in GOOPS

* module/oop/goops.scm (multiple-arity-dispatcher): Fix dispatch for
  max-arity+1 when a generic is already in multiple-arity dispatch.
  Fixes #24454.
* test-suite/tests/goops.test ("dispatch"): Add test.

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index e4f51600e5e790a43e53ef8be2b92ea565ebce17..ece03c6e06da5287b6b1c324266e42eee76d39a1 100644 (file)
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1333,7 +1333,7 @@ function."
          #`(case-lambda
              #,@(build-clauses #'(arg ...))
              (args (apply miss args)))))))
-  (arity-case (vector-length fv) 20 dispatch
+  (arity-case (1- (vector-length fv)) 20 dispatch
               (lambda args
                 (let ((nargs (length args)))
                   (if (< nargs (vector-length fv))

diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 730aabb31800a70b10e13a97b0753bae02b6e9df..259eba84bdc66ce85a83920f1f62e8d04419ade4 100644 (file)
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -690,3 +690,14 @@
       (class (<a>) (slot) #:name '<static-sub> #:static-slot-allocation? #t))
     (pass-if-equal "non-static subclass" '(a d)
       (map slot-definition-name (class-slots (class (<a>) (d) #:name '<ad>))))))
+
+(with-test-prefix "dispatch"
+  (pass-if-equal "multi-arity dispatch" 0
+    (eval '(begin
+             (define-method (dispatch (x <number>) . args) 0)
+             (dispatch 1)
+             (dispatch 1 2)
+             ;; By now "dispatch" is forced into multi-arity mode.  Test
+             ;; that the multi-arity dispatcher works:
+             (dispatch 1 2 3))
+         (current-module))))