[Guile-commits] 02/02: Fix multi-arity dispatch in GOOPS

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit c7fb87cd6e8ccf7e2a47c715a1d4a6cf82d846a3
Author: Andy Wingo <address@hidden>
Date:   Wed Feb 22 23:07:27 2017 +0100

    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.
---
 module/oop/goops.scm        |  2 +-
 test-suite/tests/goops.test | 11 +++++++++++
 2 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index e4f5160..ece03c6 100644
--- 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 730aabb..259eba8 100644
--- 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))))