mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
376 lines
14 KiB
Scheme
376 lines
14 KiB
Scheme
|
|
(import (scheme base) (scheme read) (chibi test)
|
|
(chibi show) (chibi show base) (chibi show pretty))
|
|
|
|
(test-begin "show")
|
|
|
|
;; basic data types
|
|
|
|
(test "hi" (show #f "hi"))
|
|
(test "\"hi\"" (show #f (written "hi")))
|
|
(test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\"")))
|
|
(test "\"hello\\nworld\"" (show #f (written "hello\nworld")))
|
|
(test "#(1 2 3)" (show #f (written '#(1 2 3))))
|
|
(test "(1 2 3)" (show #f (written '(1 2 3))))
|
|
(test "(1 2 . 3)" (show #f (written '(1 2 . 3))))
|
|
(test "ABC" (show #f (upcased "abc")))
|
|
(test "abc" (show #f (downcased "ABC")))
|
|
|
|
(test "abc def" (show #f "abc" (tab-to) "def"))
|
|
(test "abc def" (show #f "abc" (tab-to 5) "def"))
|
|
(test "abcdef" (show #f "abc" (tab-to 3) "def"))
|
|
|
|
;; numbers
|
|
|
|
(test "-1" (show #f -1))
|
|
(test "0" (show #f 0))
|
|
(test "1" (show #f 1))
|
|
(test "10" (show #f 10))
|
|
(test "100" (show #f 100))
|
|
(test "-1" (show #f (numeric -1)))
|
|
(test "0" (show #f (numeric 0)))
|
|
(test "1" (show #f (numeric 1)))
|
|
(test "10" (show #f (numeric 10)))
|
|
(test "100" (show #f (numeric 100)))
|
|
(test "57005" (show #f #xDEAD))
|
|
(test "#xdead" (show #f (with ((radix 16)) #xDEAD)))
|
|
(test "#xdead1234" (show #f (with ((radix 16)) #xDEAD) 1234))
|
|
(test "de.ad"
|
|
(show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100)))))
|
|
(test "d.ead"
|
|
(show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000)))))
|
|
(test "0.dead"
|
|
(show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000)))))
|
|
(test "1g"
|
|
(show #f (with ((radix 17)) (numeric 33))))
|
|
|
|
(test "3.14159" (show #f 3.14159))
|
|
(test "3.14" (show #f (with ((precision 2)) 3.14159)))
|
|
(test "3.14" (show #f (with ((precision 2)) 3.14)))
|
|
(test "3.00" (show #f (with ((precision 2)) 3.)))
|
|
(test "1.10" (show #f (with ((precision 2)) 1.099)))
|
|
(test "0.00" (show #f (with ((precision 2)) 1e-17)))
|
|
(test "0.0000000010" (show #f (with ((precision 10)) 1e-9)))
|
|
(test "0.0000000000" (show #f (with ((precision 10)) 1e-17)))
|
|
(test "0.000004" (show #f (with ((precision 6)) 0.000004)))
|
|
(test "0.0000040" (show #f (with ((precision 7)) 0.000004)))
|
|
(test "0.00000400" (show #f (with ((precision 8)) 0.000004)))
|
|
|
|
(test " 3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159))))
|
|
(test " 31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159))))
|
|
(test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159))))
|
|
(test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59))))
|
|
(test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9))))
|
|
(test " -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159))))
|
|
(test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159))))
|
|
(test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159))))
|
|
(test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59))))
|
|
(test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9))))
|
|
|
|
(cond
|
|
((exact? (/ 1 3)) ;; exact rationals
|
|
(test "333.333333333333333333333333333333"
|
|
(show #f (with ((precision 30)) (numeric 1000/3))))
|
|
(test "33.333333333333333333333333333333"
|
|
(show #f (with ((precision 30)) (numeric 100/3))))
|
|
(test "3.333333333333333333333333333333"
|
|
(show #f (with ((precision 30)) (numeric 10/3))))
|
|
(test "0.333333333333333333333333333333"
|
|
(show #f (with ((precision 30)) (numeric 1/3))))
|
|
(test "0.033333333333333333333333333333"
|
|
(show #f (with ((precision 30)) (numeric 1/30))))
|
|
(test "0.003333333333333333333333333333"
|
|
(show #f (with ((precision 30)) (numeric 1/300))))
|
|
(test "0.000333333333333333333333333333"
|
|
(show #f (with ((precision 30)) (numeric 1/3000))))
|
|
(test "0.666666666666666666666666666667"
|
|
(show #f (with ((precision 30)) (numeric 2/3))))
|
|
(test "0.090909090909090909090909090909"
|
|
(show #f (with ((precision 30)) (numeric 1/11))))
|
|
(test "1.428571428571428571428571428571"
|
|
(show #f (with ((precision 30)) (numeric 10/7))))
|
|
(test "0.123456789012345678901234567890"
|
|
(show #f (with ((precision 30))
|
|
(numeric (/ 123456789012345678901234567890
|
|
1000000000000000000000000000000)))))
|
|
(test " 333.333333333333333333333333333333"
|
|
(show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3))))
|
|
(test " 33.333333333333333333333333333333"
|
|
(show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3))))
|
|
(test " 3.333333333333333333333333333333"
|
|
(show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3))))
|
|
(test " 0.333333333333333333333333333333"
|
|
(show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3))))
|
|
))
|
|
|
|
(test "11.75" (show #f (with ((precision 2)) (/ 47 4))))
|
|
(test "-11.75" (show #f (with ((precision 2)) (/ -47 4))))
|
|
|
|
(test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33))))
|
|
|
|
(test "299792458" (show #f (with ((comma-rule 3)) 299792458)))
|
|
(test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458))))
|
|
(test "-29,97,92,458"
|
|
(show #f (with ((comma-rule '(3 . 2))) (numeric -299792458))))
|
|
(test "299.792.458"
|
|
(show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458))))
|
|
(test "299.792.458,0"
|
|
(show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0))))
|
|
|
|
(test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000))))
|
|
(test "100,000.0"
|
|
(show #f (with ((comma-rule 3) (precision 1)) (numeric 100000))))
|
|
(test "100,000.00"
|
|
(show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))
|
|
|
|
(cond-expand
|
|
(complex
|
|
(test "1+2i" (show #f (string->number "1+2i")))
|
|
(test "1.00+2.00i"
|
|
(show #f (with ((precision 2)) (string->number "1+2i"))))
|
|
(test "3.14+2.00i"
|
|
(show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
|
|
|
|
;; padding/trimming
|
|
|
|
(test "abc " (show #f (padded 5 "abc")))
|
|
(test " abc" (show #f (padded/left 5 "abc")))
|
|
(test " abc " (show #f (padded/both 5 "abc")))
|
|
(test "abcde" (show #f (padded 5 "abcde")))
|
|
(test "abcdef" (show #f (padded 5 "abcdef")))
|
|
|
|
(test "abc" (show #f (trimmed 3 "abcde")))
|
|
(test "abc" (show #f (trimmed 3 "abcd")))
|
|
(test "abc" (show #f (trimmed 3 "abc")))
|
|
(test "ab" (show #f (trimmed 3 "ab")))
|
|
(test "a" (show #f (trimmed 3 "a")))
|
|
(test "cde" (show #f (trimmed/left 3 "abcde")))
|
|
(test "bcd" (show #f (trimmed/both 3 "abcde")))
|
|
(test "bcdef" (show #f (trimmed/both 5 "abcdefgh")))
|
|
(test "abc" (show #f (trimmed/lazy 3 "abcde")))
|
|
(test "abc" (show #f (trimmed/lazy 3 "abc\nde")))
|
|
|
|
(test "prefix: abc" (show #f "prefix: " (trimmed 3 "abcde")))
|
|
(test "prefix: cde" (show #f "prefix: " (trimmed/left 3 "abcde")))
|
|
(test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde")))
|
|
(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde")))
|
|
(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde")))
|
|
|
|
(test "abc :suffix" (show #f (trimmed 3 "abcde") " :suffix"))
|
|
(test "cde :suffix" (show #f (trimmed/left 3 "abcde") " :suffix"))
|
|
(test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix"))
|
|
(test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
|
|
(test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))
|
|
|
|
(test "abcde"
|
|
(show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
|
|
(test "ab..."
|
|
(show #f (with ((ellipsis "...")) (trimmed 5 "abcdef"))))
|
|
(test "abc..."
|
|
(show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg"))))
|
|
(test "abcde"
|
|
(show #f (with ((ellipsis "...")) (trimmed/left 5 "abcde"))))
|
|
(test "...ef"
|
|
(show #f (with ((ellipsis "...")) (trimmed/left 5 "abcdef"))))
|
|
(test "...efg"
|
|
(show #f (with ((ellipsis "...")) (trimmed/left 6 "abcdefg"))))
|
|
(test "abcdefg"
|
|
(show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg"))))
|
|
(test "...d..."
|
|
(show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh"))))
|
|
(test "...e..."
|
|
(show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi"))))
|
|
|
|
(test "abc " (show #f (fitted 5 "abc")))
|
|
(test " abc" (show #f (fitted/left 5 "abc")))
|
|
(test " abc " (show #f (fitted/both 5 "abc")))
|
|
(test "abcde" (show #f (fitted 5 "abcde")))
|
|
(test "abcde" (show #f (fitted/left 5 "abcde")))
|
|
(test "abcde" (show #f (fitted/both 5 "abcde")))
|
|
(test "abcde" (show #f (fitted 5 "abcdefgh")))
|
|
(test "defgh" (show #f (fitted/left 5 "abcdefgh")))
|
|
(test "bcdef" (show #f (fitted/both 5 "abcdefgh")))
|
|
|
|
(test "prefix: abc :suffix"
|
|
(show #f "prefix: " (fitted 5 "abc") " :suffix"))
|
|
(test "prefix: abc :suffix"
|
|
(show #f "prefix: " (fitted/left 5 "abc") " :suffix"))
|
|
(test "prefix: abc :suffix"
|
|
(show #f "prefix: " (fitted/both 5 "abc") " :suffix"))
|
|
(test "prefix: abcde :suffix"
|
|
(show #f "prefix: " (fitted 5 "abcde") " :suffix"))
|
|
(test "prefix: abcde :suffix"
|
|
(show #f "prefix: " (fitted/left 5 "abcde") " :suffix"))
|
|
(test "prefix: abcde :suffix"
|
|
(show #f "prefix: " (fitted/both 5 "abcde") " :suffix"))
|
|
(test "prefix: abcde :suffix"
|
|
(show #f "prefix: " (fitted 5 "abcdefgh") " :suffix"))
|
|
(test "prefix: defgh :suffix"
|
|
(show #f "prefix: " (fitted/left 5 "abcdefgh") " :suffix"))
|
|
(test "prefix: bcdef :suffix"
|
|
(show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix"))
|
|
|
|
;; joining
|
|
|
|
(test "1 2 3" (show #f (joined each '(1 2 3) " ")))
|
|
|
|
(test ":abc:123"
|
|
(show #f (joined/prefix
|
|
(lambda (x) (trimmed 3 x))
|
|
'("abcdef" "123456")
|
|
":")))
|
|
|
|
(test "abc\n123\n"
|
|
(show #f (joined/suffix
|
|
(lambda (x) (trimmed 3 x))
|
|
'("abcdef" "123456")
|
|
nl)))
|
|
|
|
(test "lions, tigers, and bears"
|
|
(show #f (joined/last
|
|
each
|
|
(lambda (x) (each "and " x))
|
|
'(lions tigers bears)
|
|
", ")))
|
|
|
|
(test "lions, tigers, or bears"
|
|
(show #f (joined/dot
|
|
each
|
|
(lambda (x) (each "or " x))
|
|
'(lions tigers . bears)
|
|
", ")))
|
|
|
|
;; shared structures
|
|
|
|
(test "#0=(1 . #0#)"
|
|
(show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones))))
|
|
(test "(0 . #0=(1 . #0#))"
|
|
(show #f (written (let ((ones (list 1)))
|
|
(set-cdr! ones ones)
|
|
(cons 0 ones)))))
|
|
(test "(sym . #0=(sym . #0#))"
|
|
(show #f (written (let ((syms (list 'sym)))
|
|
(set-cdr! syms syms)
|
|
(cons 'sym syms)))))
|
|
(test "(#0=(1 . #0#) #1=(2 . #1#))"
|
|
(show #f (written (let ((ones (list 1))
|
|
(twos (list 2)))
|
|
(set-cdr! ones ones)
|
|
(set-cdr! twos twos)
|
|
(list ones twos)))))
|
|
(test "(#0=(1 . #0#) #0#)"
|
|
(show #f (written (let ((ones (list 1)))
|
|
(set-cdr! ones ones)
|
|
(list ones ones)))))
|
|
(test "((1) (1))"
|
|
(show #f (written (let ((ones (list 1)))
|
|
(list ones ones)))))
|
|
|
|
(test "(#0=(1) #0#)"
|
|
(show #f (written-shared (let ((ones (list 1)))
|
|
(list ones ones)))))
|
|
|
|
;; cycles without shared detection
|
|
|
|
(test "(1 1 1 1 1"
|
|
(show #f (trimmed/lazy
|
|
10
|
|
(written-simply
|
|
(let ((ones (list 1))) (set-cdr! ones ones) ones)))))
|
|
|
|
(test "(1 1 1 1 1 "
|
|
(show #f (trimmed/lazy
|
|
11
|
|
(written-simply
|
|
(let ((ones (list 1))) (set-cdr! ones ones) ones)))))
|
|
|
|
;; pretty printing
|
|
|
|
(define-syntax test-pretty
|
|
(syntax-rules ()
|
|
((test-pretty str)
|
|
(let ((sexp (read (open-input-string str))))
|
|
(test str (show #f (pretty sexp)))))))
|
|
|
|
(test-pretty "(foo bar)\n")
|
|
|
|
(test-pretty
|
|
"((self . aquanet-paper-1991)
|
|
(type . paper)
|
|
(title . \"Aquanet: a hypertext tool to hold your\"))
|
|
")
|
|
|
|
(test-pretty
|
|
"(abracadabra xylophone
|
|
bananarama
|
|
yellowstonepark
|
|
cryptoanalysis
|
|
zebramania
|
|
delightful
|
|
wubbleflubbery)\n")
|
|
|
|
(test-pretty
|
|
"#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
|
|
26 27 28 29 30 31 32 33 34 35 36 37)\n")
|
|
|
|
(test-pretty
|
|
"(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
|
|
26 27 28 29 30 31 32 33 34 35 36 37)\n")
|
|
|
|
(test-pretty
|
|
"(define (fold kons knil ls)
|
|
(define (loop ls acc)
|
|
(if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
|
|
(loop ls knil))\n")
|
|
|
|
(test-pretty
|
|
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")
|
|
|
|
(test-pretty
|
|
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
|
|
(vector-set! vec i 'supercalifrajalisticexpialidocious))\n")
|
|
|
|
(test-pretty
|
|
"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
|
|
((= index 5) my-vector)
|
|
(vector-set! my-vector index index))\n")
|
|
|
|
(test-pretty
|
|
"(define (fold kons knil ls)
|
|
(let loop ((ls ls) (acc knil))
|
|
(if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")
|
|
|
|
(test-pretty
|
|
"(define (file->sexp-list pathname)
|
|
(call-with-input-file pathname
|
|
(lambda (port)
|
|
(let loop ((res '()))
|
|
(let ((line (read port)))
|
|
(if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")
|
|
|
|
(test-pretty
|
|
"(design
|
|
(module (name \"\\\\testshiftregister\")
|
|
(attributes
|
|
(attribute (name \"\\\\src\") (value \"testshiftregister.v:10\"))))
|
|
(wire (name \"\\\\shreg\")
|
|
(attributes
|
|
(attribute (name \"\\\\src\") (value \"testshiftregister.v:15\")))))\n")
|
|
|
|
(test "(let ((ones '#0=(1 . #0#))) ones)\n"
|
|
(show #f (pretty (let ((ones (list 1)))
|
|
(set-cdr! ones ones)
|
|
`(let ((ones ',ones)) ones)))))
|
|
|
|
'(test
|
|
"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
|
|
(ones '#0=(1 . #0#)))
|
|
(append zeros ones))\n"
|
|
(show #f (pretty
|
|
(let ((ones (list 1)))
|
|
(set-cdr! ones ones)
|
|
`(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
|
|
(ones ',ones))
|
|
(append zeros ones))))))
|
|
|
|
(test-end)
|