mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-11 06:57:33 +02:00
fixing dotted arg case of srfi-16
This commit is contained in:
parent
04210ff14a
commit
94037929be
2 changed files with 46 additions and 1 deletions
|
@ -13,7 +13,7 @@
|
||||||
(%case args len (+ n 1) (p ... x) (y . body) . rest))
|
(%case args len (+ n 1) (p ... x) (y . body) . rest))
|
||||||
((%case args len n (p ...) (y . body) . rest)
|
((%case args len n (p ...) (y . body) . rest)
|
||||||
(if (>= len n)
|
(if (>= len n)
|
||||||
(apply (lambda (p ... y) . body) args)
|
(apply (lambda (p ... . y) . body) args)
|
||||||
(%case args len 0 () . rest)))
|
(%case args len 0 () . rest)))
|
||||||
((%case args len n p)
|
((%case args len n p)
|
||||||
(error "case-lambda: no cases matched"))))
|
(error "case-lambda: no cases matched"))))
|
||||||
|
|
45
tests/srfi-16-tests.scm
Normal file
45
tests/srfi-16-tests.scm
Normal file
|
@ -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)
|
Loading…
Add table
Reference in a new issue