mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
115 lines
3.9 KiB
Scheme
115 lines
3.9 KiB
Scheme
|
|
(define-library (chibi optional-test)
|
|
(import (scheme base) (chibi optional))
|
|
(cond-expand
|
|
(chibi (import (chibi test)))
|
|
(else
|
|
(import (scheme write))
|
|
;; inline (chibi test) to avoid circular dependencies in snow
|
|
;; installations
|
|
(begin
|
|
(define-syntax test
|
|
(syntax-rules ()
|
|
((test expect expr)
|
|
(test 'expr expect expr))
|
|
((test name expect expr)
|
|
(guard (exn (else (display "!\nERROR: ") (write name) (newline)
|
|
(write exn) (newline)))
|
|
(let* ((res expr)
|
|
(pass? (equal? expect expr)))
|
|
(display (if pass? "." "x"))
|
|
(cond
|
|
((not pass?)
|
|
(display "\nFAIL: ") (write name) (newline))))))))
|
|
(define-syntax test-assert
|
|
(syntax-rules ()
|
|
((test-assert expr) (test #t expr))))
|
|
(define-syntax test-error
|
|
(syntax-rules ()
|
|
((test-error expr)
|
|
(test-assert (guard (exn (else #t)) expr #f)))))
|
|
(define (test-begin name)
|
|
(display name))
|
|
(define (test-end)
|
|
(newline)))))
|
|
(export run-tests)
|
|
(begin
|
|
(define (run-tests)
|
|
(test-begin "optional")
|
|
(test '(0 11 12)
|
|
(let-optionals '(0) ((a 10) (b 11) (c 12))
|
|
(list a b c)))
|
|
(test '(0 11 12)
|
|
((opt-lambda ((a 10) (b 11) (c 12))
|
|
(list a b c))
|
|
0))
|
|
(test '(0 11 12)
|
|
((opt-lambda (a (b 11) (c 12))
|
|
(list a b c))
|
|
0))
|
|
(test '(0 11 2)
|
|
(let ((b 1))
|
|
((opt-lambda (a (b 11) (c (* b 2)))
|
|
(list a b c))
|
|
0)))
|
|
(test '(0 11 22)
|
|
(let ((b 1))
|
|
((opt-lambda* (a (b 11) (c (* b 2)))
|
|
(list a b c))
|
|
0)))
|
|
(test '(0 1 (2 3 4))
|
|
(let-optionals* '(0 1 2 3 4) ((a 10) (b 11) . c)
|
|
(list a b c)))
|
|
(test '(0 1 (2 3 4))
|
|
(let-optionals '(0 1 2 3 4) ((a 10) (b 11) . c)
|
|
(list a b c)))
|
|
(test '(0 1 (2 3 4))
|
|
(let-optionals* '(0 1 2 3 4) (a (b 11) . c)
|
|
(list a b c)))
|
|
(test '(0 1 (2 3 4))
|
|
(let-optionals '(0 1 2 3 4) (a (b 11) . c)
|
|
(list a b c)))
|
|
(let ((ls '()))
|
|
(let-optionals* ls ((a (begin (set! ls '(a b)) 'default-a))
|
|
(b 'default-b))
|
|
(test '(default-a default-b) (list a b))))
|
|
(let ((ls (list 0 1 2)))
|
|
(let-optionals ls (a . b)
|
|
(set-car! (cdr ls) 3)
|
|
(test '(0 3 2) ls)
|
|
(test '(0 1 2) (cons a b))))
|
|
(test 5 (keyword-ref '(a: b: b: 5) 'b: #f))
|
|
(test 5 (keyword-ref* '(a: b: b: 5) 'b: #f))
|
|
(test '(1 2 0 (other: 9))
|
|
(let-keywords '(b: 2 a: 1 other: 9)
|
|
((a 0) (b 0) (c 0) rest)
|
|
(list a b c rest)))
|
|
;; a: is not in a keyword position, and the 3 is dropped
|
|
(test '(1 (2 a:))
|
|
(let-keywords '(2 a: 3) ((a a: 1) rest) (list a rest)))
|
|
;; a: is in a keyword position, and the 3 is dropped
|
|
(test '(2 ())
|
|
(let-keywords '(a: 2 3) ((a a: 1) rest) (list a rest)))
|
|
;; a: is in a keyword position, 3->5 is a kv, 4 is dropped
|
|
(test '(2 (3 5))
|
|
(let-keywords '(3 5 a: 2 4) ((a a: 1) rest) (list a rest)))
|
|
;; a: is in a keyword position, 3->5 and 4->6 are kvs
|
|
(test '(2 (3 5 4 6))
|
|
(let-keywords '(3 5 a: 2 4 6) ((a a: 1) rest) (list a rest)))
|
|
(cond-expand
|
|
(gauche) ; gauche detects this at compile-time, can't catch
|
|
(else (test-error '(0 11 12)
|
|
((opt-lambda (a (b 11) (c 12))
|
|
(list a b c))))))
|
|
(let ()
|
|
(define-opt (f a (b 11) (c 12))
|
|
(list a b c))
|
|
(cond-expand
|
|
(gauche)
|
|
(else
|
|
(test-error (f))))
|
|
(test '(0 11 12) (f 0))
|
|
(test '(0 1 12) (f 0 1))
|
|
(test '(0 1 2) (f 0 1 2))
|
|
(test '(0 1 2) (f 0 1 2 3)))
|
|
(test-end))))
|