mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

fix bug in goops' method cache with rest args

Browse source 
* module/oop/goops/compile.scm (code-table-lookup): Fix a tricky little
  bug!

* test-suite/tests/goops.test ("the method cache"): Add a wee test.
This commit is contained in:
Andy Wingo 2009-06-06 14:07:29 +02:00
parent 12798872ff
commit 4bcc952d45
2 changed files with 19 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

11
module/oop/goops/compile.scm
View file

@ -34,11 +34,12 @@
(define code-table-lookup (define code-table-lookup
(letrec ((check-entry (lambda (entry types) (letrec ((check-entry (lambda (entry types)
(if (null? types) (cond
(and (not (struct? (car entry))) ((not (pair? entry)) (and (null? types) entry))
entry) ((null? types) #f)
(and (eq? (car entry) (car types)) (else
(check-entry (cdr entry) (cdr types))))))) (and (eq? (car entry) (car types))
(check-entry (cdr entry) (cdr types))))))))
(lambda (code-table types) (lambda (code-table types)
(cond ((null? code-table) #f) (cond ((null? code-table) #f)
((check-entry (car code-table) types)) ((check-entry (car code-table) types))

13
test-suite/tests/goops.test
View file

@ -261,6 +261,19 @@
(method-more-specific? m1 m2 '())) (method-more-specific? m1 m2 '()))
(current-module)))) (current-module))))
(with-test-prefix "the method cache"
(pass-if "defining a method with a rest arg"
(let ((m (current-module)))
(eval '(define-method (foo bar . baz)
(cons bar baz))
m)
(eval '(foo 1)
m)
(eval '(foo 1 2)
m)
(eval '(equal? (foo 1 2) '(1 2))
m))))
(with-test-prefix "defining accessors" (with-test-prefix "defining accessors"
(with-test-prefix "define-accessor" (with-test-prefix "define-accessor"