From 94037929be9c811823bc66e3b1e66d825fc11657 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 24 Apr 2012 07:23:54 +0900 Subject: [PATCH] fixing dotted arg case of srfi-16 --- lib/srfi/16.sld | 2 +- tests/srfi-16-tests.scm | 45 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+), 1 deletion(-) create mode 100644 tests/srfi-16-tests.scm diff --git a/lib/srfi/16.sld b/lib/srfi/16.sld index 418958d5..5806acf2 100644 --- a/lib/srfi/16.sld +++ b/lib/srfi/16.sld @@ -13,7 +13,7 @@ (%case args len (+ n 1) (p ... x) (y . body) . rest)) ((%case args len n (p ...) (y . body) . rest) (if (>= len n) - (apply (lambda (p ... y) . body) args) + (apply (lambda (p ... . y) . body) args) (%case args len 0 () . rest))) ((%case args len n p) (error "case-lambda: no cases matched")))) diff --git a/tests/srfi-16-tests.scm b/tests/srfi-16-tests.scm new file mode 100644 index 00000000..c88f2243 --- /dev/null +++ b/tests/srfi-16-tests.scm @@ -0,0 +1,45 @@ + +(cond-expand + (modules (import (scheme) (chibi test) (srfi 16))) + (else #f)) + +(define plus + (case-lambda + (() 0) + ((x) x) + ((x y) (+ x y)) + ((x y z) (+ (+ x y) z)) + (args (apply + args)))) + +(test-begin "case-lambda") + +(test 0 (plus)) +(test 1 (plus 1)) +(test 6 (plus 1 2 3)) +(test-error ((case-lambda ((a) a) ((a b) (* a b))) 1 2 3)) + +(define print + (case-lambda + (() + (display "")) + ((arg) + (display arg)) + ((arg . args) + (display arg) + (display " ") + (apply print args)))) + +(define (print-to-string . args) + (let ((out (open-output-string)) + (old-out (current-output-port))) + (dynamic-wind + (lambda () (current-output-port out)) + (lambda () (apply print args)) + (lambda () (current-output-port old-out))) + (get-output-string out))) + +(test "" (print-to-string)) +(test "hi" (print-to-string 'hi)) +(test "hi there world" (print-to-string 'hi 'there 'world)) + +(test-end)