Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

move definitions to start of body

Browse source
This commit is contained in:
Alex Shinn 2016-02-28 18:05:02 +09:00
parent 8ea51a77ce
commit b60a9a28a7
15 changed files with 257 additions and 260 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
lib/chibi/crypto/rsa-test.sld
View file

@ -6,23 +6,28 @@
(chibi test))
(begin
(define (run-tests)
(define (test-key key)
(test #t (rsa-key? key))
(test #t (positive? (rsa-key-n key)))
(test #t (positive? (rsa-key-e key)))
(test #t (positive? (rsa-key-d key)))
(test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
(test-begin "rsa")
;; Verify an explicit key.
;; p = 61, q = 53
(define priv-key (rsa-key-gen-from-primes 8 61 53))
(define pub-key (rsa-pub-key priv-key))
(let* ((priv-key (rsa-key-gen-from-primes 8 61 53))
(pub-key (rsa-pub-key priv-key)))
(test 439 (rsa-sign priv-key 42))
(test #t (rsa-verify? pub-key 42 (rsa-sign priv-key 42)))
(let ((msg 42))
(test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg))))
(define priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
(define pub-key2 (rsa-pub-key priv-key2))
(test msg (rsa-decrypt priv-key (rsa-encrypt pub-key msg)))))
(let* ((priv-key2 (rsa-key-gen-from-primes 32 2936546443 3213384203))
(pub-key2 (rsa-pub-key priv-key2)))
(let ((msg 42))
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
@ -36,17 +41,10 @@
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
(let ((msg #u8(42)))
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg))))
(test #t (rsa-verify? pub-key2 msg (rsa-sign priv-key2 msg)))))
;; Key generation.
(define (test-key key)
(test #t (rsa-key? key))
(test #t (positive? (rsa-key-n key)))
(test #t (positive? (rsa-key-e key)))
(test #t (positive? (rsa-key-d key)))
(test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5))))
(test-key (rsa-key-gen 8))
(test-key (rsa-key-gen 16))
(test-key (rsa-key-gen 32))

26
lib/chibi/io-test.sld
View file

@ -6,10 +6,21 @@
(only (chibi test) test-begin test test-end))
(begin
(define (run-tests)
(test-begin "io")
(define long-string (make-string 2000 #\a))
(define (string-upcase str)
(list->string (map char-upcase (string->list str))))
(define (strings->input-port str-ls)
(make-generated-input-port
(lambda ()
(and (pair? str-ls)
(let ((res (car str-ls)))
(set! str-ls (cdr str-ls))
res)))))
(test-begin "io")
(test "input-string-port" 1025
(call-with-input-string (substring long-string 0 1025)
(lambda (in)
@ -78,9 +89,6 @@
(close-input-port in)
res)))
(define (string-upcase str)
(list->string (map char-upcase (string->list str))))
(test "upcase-input-port" "ABC"
(call-with-input-string "abc"
(lambda (in)
@ -96,14 +104,6 @@
(display "abc" out)
(close-output-port out)))))
(define (strings->input-port str-ls)
(make-generated-input-port
(lambda ()
(and (pair? str-ls)
(let ((res (car str-ls)))
(set! str-ls (cdr str-ls))
res)))))
(test "abcdef" (read-line (strings->input-port '("abcdef"))))
(test "abcdef" (read-line (strings->input-port '("abc" "def"))))
(test "abcdef"

15
lib/chibi/loop-test.sld
View file

@ -2,6 +2,13 @@
(export run-tests)
(import (chibi) (chibi loop) (only (chibi test) test-begin test test-end))
(begin
(define (flatten ls)
(reverse
(loop lp ((for x ls (in-list ls)) (with res '()))
=> res
(if (pair? x)
(lp (=> res (lp (=> ls x))))
(lp (=> res (cons x res)))))))
(define (run-tests)
(test-begin "loops")
@ -55,14 +62,6 @@
(for res (listing ls)))
=> res))
(define (flatten ls)
(reverse
(loop lp ((for x ls (in-list ls)) (with res '()))
=> res
(if (pair? x)
(lp (=> res (lp (=> ls x))))
(lp (=> res (cons x res)))))))
(test
"flatten (recursion test)"
'(1 2 3 4 5 6 7)

14
lib/chibi/match-test.sld
View file

@ -3,6 +3,15 @@
(import (except (scheme base) equal?)
(chibi match)
(only (chibi test) test-begin test test-end))
(cond-expand
(chibi
(begin
(define-record-type Point
(make-point x y)
point?
(x point-x point-x-set!)
(y point-y point-y-set!))))
(else))
(begin
(define (run-tests)
(test-begin "match")
@ -179,11 +188,6 @@
(cond-expand
(chibi
(define-record-type Point
(make-point x y)
point?
(x point-x point-x-set!)
(y point-y point-y-set!))
(test "record positional"
'(1 0)
(match (make-point 0 1)

20
lib/chibi/numeric-test.sld
View file

@ -6,6 +6,13 @@
(list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x)))
(define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1)))))
(define (atanh z) (/ (- (log (+ 1 z)) (log (- 1 z))) 2))
(define (integer-arithmetic-combinations a b)
(list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b)))
(define (sign-combinations a b)
(list (integer-arithmetic-combinations a b)
(integer-arithmetic-combinations (- a) b)
(integer-arithmetic-combinations a (- b))
(integer-arithmetic-combinations (- a) (- b))))
(define (run-tests)
(test-begin "numbers")
@ -62,15 +69,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (integer-arithmetic-combinations a b)
(list (+ a b) (- a b) (* a b) (quotient a b) (remainder a b)))
(define (sign-combinations a b)
(list (integer-arithmetic-combinations a b)
(integer-arithmetic-combinations (- a) b)
(integer-arithmetic-combinations a (- b))
(integer-arithmetic-combinations (- a) (- b))))
;; fix x fix
(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0))
(sign-combinations 0 1))
@ -136,8 +134,6 @@
4294967296 -1))
(sign-combinations (+ 1 (expt 2 64)) (expt 2 32)))
(define M7 (- (expt 2 127) 1))
(test '((170141183460469231750134047789593657344
170141183460469231713240559642174554110
3138550867693340382088035895064302439764418281874191810559
@ -158,7 +154,7 @@
3138550867693340382088035895064302439764418281874191810559
9223372036854775807
-9223372036854775808))
(sign-combinations M7 (+ 1 (expt 2 64))))
(sign-combinations (- (expt 2 127) 1) (+ 1 (expt 2 64))))
;; fixnum-bignum boundaries (machine word - 1 bit for sign - 2
;; bits for tag)

3
lib/chibi/regexp-test.sld
View file

@ -224,6 +224,7 @@
(regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 4))
(test " abc d ef " (regexp-replace-all '(+ space) " abc \t\n d ef " " "))
(let ()
(define (subst-matches matches input subst)
(define (submatch n)
(regexp-match-submatch matches n))
@ -279,6 +280,6 @@
(lambda (in)
(for-each
(lambda (line) (test-pcre line))
(port->list read-line in)))))
(port->list read-line in))))))
(test-end))))

11
lib/chibi/show-test.sld
View file

@ -3,6 +3,11 @@
(import (scheme base) (scheme read) (chibi test)
(chibi show) (chibi show base) (chibi show pretty))
(begin
(define-syntax test-pretty
(syntax-rules ()
((test-pretty str)
(let ((sexp (read (open-input-string str))))
(test str (show #f (pretty sexp)))))))
(define (run-tests)
(test-begin "show")
@ -288,12 +293,6 @@
;; 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

8
lib/chibi/system-test.sld
View file

@ -27,9 +27,9 @@
;; stress test user-name
(test (user-name (user-information (current-user-id)))
(user-name (user-information (current-user-id))))
(define u (user-information (current-user-id)))
(test (user-name u) (user-name (user-information (current-user-id))))
(define un (user-name (user-information (current-user-id))))
(test un (user-name (user-information (current-user-id))))
(let ((u (user-information (current-user-id))))
(test (user-name u) (user-name (user-information (current-user-id)))))
(let ((un (user-name (user-information (current-user-id)))))
(test un (user-name (user-information (current-user-id)))))
(test-end))))

5
lib/chibi/tar-test.sld
View file

@ -12,9 +12,6 @@
(chibi tar)
(chibi test))
(begin
(define (run-tests)
(test-begin "tar")
;; Utility to flatten bytevectors, strings and individual bytes
;; (integers) into a single bytevector for generating readable test
;; data. (<byte> . <repetition>) can be used to repeat a byte.
@ -26,6 +23,8 @@
((integer? x) (bytevector x))
(else x)))
args)))
(define (run-tests)
(test-begin "tar")
(let ((b (bv "foo" '(0 . 97)
"000644 " 0

20
lib/chibi/term/ansi-test.sld
View file

@ -4,16 +4,6 @@
(chibi test)
(chibi term ansi))
(begin
(define (run-tests)
(test-begin "term.ansi")
(test-assert (procedure? ansi-escapes-enabled?))
(test-assert
(let ((tag (cons #t #t)))
(eqv? tag
(parameterize ((ansi-escapes-enabled? tag))
(ansi-escapes-enabled?)))))
(define-syntax test-escape-procedure
(syntax-rules ()
((test-escape-procedure p s)
@ -21,7 +11,6 @@
(test-assert (procedure? p))
(test-error (p #f))
(test s (p))))))
(define-syntax test-wrap-procedure
(syntax-rules ()
((test-wrap-procedure p s)
@ -36,6 +25,15 @@
(test (p "FOO")
s
(parameterize ((ansi-escapes-enabled? #t)) (p "FOO")))))))
(define (run-tests)
(test-begin "term.ansi")
(test-assert (procedure? ansi-escapes-enabled?))
(test-assert
(let ((tag (cons #t #t)))
(eqv? tag
(parameterize ((ansi-escapes-enabled? tag))
(ansi-escapes-enabled?)))))
(test-escape-procedure black-escape "\x1b;[30m")
(test-escape-procedure red-escape "\x1b;[31m")

16
lib/srfi/16/test.sld
View file

@ -10,14 +10,6 @@
((x y) (+ x y))
((x y z) (+ (+ x y) z))
(args (apply + args))))
(test-begin "srfi-16: 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
(()
@ -28,7 +20,6 @@
(display arg)
(display " ")
(apply print args))))
(define (print-to-string . args)
(let ((out (open-output-string))
(old-out (current-output-port)))
@ -38,6 +29,13 @@
(lambda () (current-output-port old-out)))
(get-output-string out)))
(test-begin "srfi-16: 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))
(test "" (print-to-string))
(test "hi" (print-to-string 'hi))
(test "hi there world" (print-to-string 'hi 'there 'world))

2
lib/srfi/27/test.sld
View file

@ -5,9 +5,9 @@
(chibi test))
(begin
(define (run-tests)
(test-begin "srfi-27: random")
(define (test-random rand n)
(test-assert (<= 0 (rand n) (- n 1))))
(test-begin "srfi-27: random")
(let ((rs (make-random-source)))
;; chosen by fair dice roll. guaranteed to be random
(random-source-pseudo-randomize! rs 4 4)

4
lib/srfi/38/test.sld
View file

@ -3,8 +3,6 @@
(import (chibi) (chibi test) (srfi 1) (srfi 38))
(begin
(define (run-tests)
(test-begin "srfi-38: shared read/write")
(define (read-from-string str)
(call-with-input-string str
(lambda (in) (read/ss in))))
@ -29,6 +27,8 @@
(test str (write-to-string value #t))
(test str (write-to-string (read-from-string str) #t))))))
(test-begin "srfi-38: shared read/write")
(test-io "(1)" (list 1))
(test-io "(1 2)" (list 1 2))
(test-io "(1 . 2)" (cons 1 2))

4
lib/srfi/69/test.sld
View file

@ -4,8 +4,6 @@
(begin
(define (run-tests)
(test-begin "srfi-69: hash-tables")
(define-syntax test-lset-eq?
(syntax-rules ()
((test-lset= . args)
@ -16,6 +14,8 @@
((test-lset-equal? . args)
(test-equal (lambda (a b) (lset= equal? a b)) . args))))
(test-begin "srfi-69: hash-tables")
(let ((ht (make-hash-table eq?)))
;; 3 initial elements
(test 0 (hash-table-size ht))

25
lib/srfi/99/test.sld
View file

@ -5,8 +5,6 @@
(only (chibi test) test-begin test-assert test test-end))
(begin
(define (run-tests)
(test-begin "srfi-99: records")
(define-record-type organism
(make-organism name)
organism?
@ -72,6 +70,8 @@
(define mickey (make-mouse "Mickey" "cheese" 10))
(define felix (make-cat "Felix" mickey 8 'mixed '(and black white)))
(test-begin "srfi-99: records")
(test-assert (organism? mickey))
(test-assert (animal? mickey))
(test-assert (chordate? mickey))
@ -112,6 +112,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
(define-record-type person #t #t (name) (sex) (age))
(define-record-type (employee person) #t #t (department) (salary))
@ -162,7 +163,7 @@
((rtd-mutator person 'age) trent 45)
(test 45 (person-age trent)))
(test-assert (rtd-field-mutable? employee 'department))
(test-assert (rtd-field-mutable? employee 'department)))
;; We do not retain mutability information ATM.
;; (define-record-type foo
@ -172,32 +173,36 @@
;;
;; (test-assert (not (rtd-field-mutable? foo 'x)))
(let ()
(define point (make-rtd "point" #(x y)))
(define make-point (rtd-constructor point #(x y)))
(define point-x (rtd-accessor point 'x))
(test 3 (point-x (make-point 3 2)))
(test 3 (point-x (make-point 3 2))))
;; Name conflicts - make sure we rename
(let ()
(define-record-type example make-example #t example)
(test-assert (example? (make-example 3)))
(test 3 (example-example (make-example 3)))
(test 3 (example-example (make-example 3))))
;; record types definitions with #f passed as either the constructor or
;; predicate argument should not create the corresponding function
(let ()
(define-record-type abstract
#f #t)
(test #f (memq 'make-abstract (env-exports (current-environment))))
(define-record-type (derived abstract)
#t #f)
(define instance (make-derived))
(test-assert (abstract? instance))
(test #f (memq 'derived? (env-exports (current-environment))))
(test #f (memq 'make-abstract (env-exports (current-environment))))
(test-assert (abstract? instance))
(test #f (memq 'derived? (env-exports (current-environment)))))
(let ()
(define-record-type container
#t #t
default-immutable
@ -216,6 +221,6 @@
(test #t (container-default-mutable container-instance))
(set-container-mutable! container-instance #t)
(test #t (get-container-mutable container-instance))
(test #t (get-container-mutable container-instance)))
(test-end))))