(import test) (import (only (chicken format) format) (test-utils gloss)) ;; (test-begin "More Macros") (import moremacros) ;; (cond-expand (compiling (test-group "Expansion Time Info" (let ((lno (__line__))) (glossf "(__date__): ~S" (__date__)) (glossf "(__time__): ~S" (__time__)) (glossf "(__file__): ~S" (__file__)) (glossf "(__line__): ~S" lno) (test "(__file__)" "moremacros-test.scm" (__file__)) (test "(__line__)" 16 lno) ) ) ) (else) ) ;; (test-group "Either/Or" (test-assert (true #f)) (test-assert (not (false #t))) (test-assert (true? #t)) (test-assert (not (true? 1))) (test-assert (false? #f)) ) #; (test-group "lets" (test 2 (lets (a 1 b a c (add1 a)) (add1 b) (void) c)) (test-assert (lets () #t)) ) (test-group "case-like operators" (test "select-with" #t (select-with string=? "bars" (("foo" (string-append "foo" "s")) 'foo) (("bar" (string-append "bar" "s")) #t) (else #f))) (test "case-with" #t (case-with eq? 'bars ((foo foos) 'foo) ((bar bars) #t) (else #f))) (test "switch" #t (switch '(foo) (("foo" 'foo) 'foo) (('(foo) 'foo) #t) (else #f))) ) (test-group "swap!" (let ((a 1) (b 2)) (test "swap! before" '(1 2) (list a b)) (swap! a b) (test "swap! after" '(2 1) (list a b)) ) ) #; (test-group "swap-set!, fluid-set!, stiff-set!" (let ((a 1) (b 2)) (test "swap-set! before" '(1 2) (list a b)) (swap-set! a b) (test "swap-set! after" '(2 1) (list a b)) ) (let ((a 1) (b 2)) (test "fluid-set! before" '(1 2) (list a b)) (fluid-set! a 23 b (+ a b) (begin (test "fluid-set! during" '(23 25) (list a b)))) (test "fluid-set! after" '(1 2) (list a b)) ) (let ((a 1) (b 2)) (test "stiff-set! before" '(1 2) (list a b)) (stiff-set! a 23 b (+ a b)) (test "stiff-set! after" '(23 25) (list a b)) ) ) (test-group "set!-op" (let ((a 1) (b 2)) (set!-op a + 2 <> b) (test 5 a) ) ) (test-group "type-case" (test 'numeric (type-case 23 ((symbol string char) 'symbolic) (number 'numeric) (else 'otheric))) (test '(23 numeric) (type-case* 23 ((symbol string char) (list it 'symbolic)) (number (list it 'numeric)) (else (list it 'otheric)))) ) (test-group "guards" (define (tstprm1) 'foo) (define tstgrd1 (warning-guard tstprm1 symbol ;ugh, automagic identifier injection (format #t "testing body: ~S " obj))) (define (check-symbol l x) (unless (symbol? x) (error l "not a symbol" x)) x) (define tstgrd2 (checked-guard tstprm1 symbol ;ugh, automagic identifier injection (format #t "testing body: ~S " obj))) (test 'bar (tstgrd1 'bar)) (test "expect warning" 'foo (tstgrd1 #f)) (test 'bar (tstgrd2 'bar)) (test-error "raises error" (tstgrd2 #f)) ) ;; (import numeric-macros) (test-group "Numeric Macros" (let ((ia 1) (fa 1.0)) (test 2 (fx++ ia)) (test 0 (fx-- ia)) (test 2.0 (fp++ fa)) (test 0.0 (fp-- fa)) (test 2.0 (fl++ fa)) (test 0.0 (fl-- fa)) (test 2 (1+ ia)) (test 2 (++ ia)) (test 2.0 (++ fa)) (test 0 (1- ia)) (test 0 (-- ia)) (test 0.0 (-- fa)) ) (let ((ia 1)) (fx++! ia) (test 2 ia) (fx--! ia) (test 1 ia) ) (let ((fa 1.0)) (fp++! fa) (test 2.0 fa) (fp--! fa) (test 1.0 fa) (fl++! fa) (test 2.0 fa) (fl--! fa) (test 1.0 fa) ) (let ((ia 1) (fa 1.0)) (++! ia) (test 2 ia) (++! fa) (test 2.0 fa) (--! ia) (test 1 ia) (--! fa) (test 1.0 fa) ) (test-assert (seven? 7)) (test-assert (not (seven? 5))) ) ;; (import hash-let srfi-69) (test-group "Hash Let" (let ((tbl (make-hash-table))) ;set! (hash-table-set! tbl 'abc "commercial network") (hash-table-set! tbl "nbc" "commercial network") ;ref (hash-let tbl ((abc) ;key symbol 'abc (cbs "nbc") ;supplied string key (pbs (string-append "p" "bs") #t) ;default value for missing "pbs" tbs) ;missing key symbol 'tbs (test "commercial network" abc) (test "commercial network" cbs) (test #t pbs) (test #f tbs) ) ) ) ;; (test-end "More Macros") (test-exit)