93 lines
3 KiB
Scheme
93 lines
3 KiB
Scheme
|
;;;; symbol-utils-test.scm -*- Scheme -*-
|
||
|
|
;;;; Kon Lovett, Jul '18
|
||
|
|
|
||
|
|
(import test)
|
||
|
|
|
||
|
|
(test-begin "Symbol Utils")
|
||
|
|
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(import symbol-utils)
|
||
|
|
|
||
|
|
(test-group "value"
|
||
|
|
(cond-expand
|
||
|
|
(compiling
|
||
|
|
(test-assert (symbol-value symbol->keyword)) )
|
||
|
|
(else) )
|
||
|
|
(test-assert (unspecified? (unspecified-value)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "keyword"
|
||
|
|
(test 'foo (keyword->symbol #:foo))
|
||
|
|
(test "foo" (symbol->string (keyword->uninterned-symbol #:foo)))
|
||
|
|
(test #:foo (symbol->keyword 'foo))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "printname"
|
||
|
|
(test-assert (symbol-printname=? 'foo 'foo))
|
||
|
|
(test-assert (not (symbol-printname=? 'foo 'bar)))
|
||
|
|
(test-assert (symbol-printname=? '##sys#list->string '##sys#list->string))
|
||
|
|
(test-assert (not (symbol-printname=? '##sys#list->string 'list->string)))
|
||
|
|
|
||
|
|
(test-assert (not (symbol-printname<? 'foo 'foo)))
|
||
|
|
(test-assert (symbol-printname<? 'bar 'foo))
|
||
|
|
(test-assert (not (symbol-printname<? '##sys#list->string '##sys#list->string)))
|
||
|
|
#;(test-assert (symbol-printname<? 'list->string '##sys#list->string))
|
||
|
|
|
||
|
|
(test-assert (symbol-printname-ci=? 'foo 'FOO))
|
||
|
|
(test-assert (not (symbol-printname-ci=? 'foo 'BAR)))
|
||
|
|
(test-assert (symbol-printname-ci=? '##sys#list->string '##sys#list->STRING))
|
||
|
|
(test-assert (not (symbol-printname-ci=? '##sys#list->string 'list->STRING)))
|
||
|
|
|
||
|
|
(test-assert (not (symbol-printname-ci<? 'foo 'FOO)))
|
||
|
|
(test-assert (symbol-printname-ci<? 'bar 'FOO))
|
||
|
|
(test-assert (not (symbol-printname-ci<? '##sys#list->string '##sys#list->STRING)))
|
||
|
|
#;(test-assert (symbol-printname-ci<? 'list->string '##sys#list->STRING))
|
||
|
|
|
||
|
|
(test 3 (symbol-printname-length 'foo))
|
||
|
|
(test 4 (symbol-printname-length #:foo))
|
||
|
|
(test 5 (symbol-printname-length #:foo #t))
|
||
|
|
|
||
|
|
(test 0 (max-symbol-printname-length '()))
|
||
|
|
(test 3 (max-symbol-printname-length '(a abc ab)))
|
||
|
|
(test 5 (max-symbol-printname-length '(a abc ab #:foo) #t))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "module printname"
|
||
|
|
(test-assert "must be list" (not (module-printnames "abc")))
|
||
|
|
(test-assert "not a #" (not (module-printnames '(a 23 "c"))))
|
||
|
|
(test-assert "xplody must be symbol" (not (module-printnames '(a (b "c") "d"))))
|
||
|
|
(test-assert "no negatives" (not (module-printnames '(a (srfi -8) "d"))))
|
||
|
|
(let ((mns (module-printnames '((foo bar baz) foo (srfi 0)))))
|
||
|
|
(test "xplody" "foo.bar.baz" (car mns))
|
||
|
|
(test "just a'" "foo" (cadr mns))
|
||
|
|
(test "special" "srfi-0" (caddr mns)) )
|
||
|
|
)
|
||
|
|
|
||
|
|
#;
|
||
|
|
(test-group "qualified"
|
||
|
|
(test '##foo#bar (make-qualified-symbol "foo" 'bar))
|
||
|
|
(test-assert (qualified-symbol? '##sys#list->string))
|
||
|
|
(test-assert (not (qualified-symbol? 'sym)))
|
||
|
|
(test "##sys#list->string" (symbol->qualified-string '##sys#list->string))
|
||
|
|
(test "list->string" (symbol->qualified-string 'list->string))
|
||
|
|
(test-assert (not (interned-symbol? (make-qualified-uninterned-symbol "bar" 'foo))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "interned"
|
||
|
|
(test-assert (interned-symbol? 'foo))
|
||
|
|
(test-assert (not (interned-symbol? (gensym))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "gensym"
|
||
|
|
(let ((gen (make-gensym 'test)))
|
||
|
|
(test "gen 0" "test0" (symbol->string (gen)))
|
||
|
|
(test "gen 1" "testfoo1" (symbol->string (gen 'foo))) )
|
||
|
|
)
|
||
|
|
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(test-end "Symbol Utils")
|
||
|
|
|
||
|
|
(test-exit)
|