mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
move definitions to start of body
This commit is contained in:
Alex Shinn
parent
8ea51a77ce
commit
b60a9a28a7
15 changed files with 257 additions and 260 deletions
|
|
@ -6,39 +6,6 @@
|
|||
(chibi test))
|
||||
(begin
|
||||
(define (run-tests)
|
||||
(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))
|
||||
|
||||
(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))
|
||||
|
||||
(let ((msg 42))
|
||||
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
|
||||
|
||||
(let ((msg #u8(42)))
|
||||
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
|
||||
|
||||
(let ((msg "*"))
|
||||
(test msg (utf8->string (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg)))))
|
||||
|
||||
(let ((msg "*"))
|
||||
(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))))
|
||||
|
||||
;; Key generation.
|
||||
|
||||
(define (test-key key)
|
||||
(test #t (rsa-key? key))
|
||||
|
|
@ -47,6 +14,37 @@
|
|||
(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
|
||||
(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)))))
|
||||
|
||||
(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))))
|
||||
|
||||
(let ((msg #u8(42)))
|
||||
(test msg (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg))))
|
||||
|
||||
(let ((msg "*"))
|
||||
(test msg (utf8->string (rsa-decrypt priv-key2 (rsa-encrypt pub-key2 msg)))))
|
||||
|
||||
(let ((msg "*"))
|
||||
(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)))))
|
||||
|
||||
;; Key generation.
|
||||
|
||||
(test-key (rsa-key-gen 8))
|
||||
(test-key (rsa-key-gen 16))
|
||||
(test-key (rsa-key-gen 32))
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -224,61 +224,62 @@
|
|||
(regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 4))
|
||||
(test " abc d ef " (regexp-replace-all '(+ space) " abc \t\n d ef " " "))
|
||||
|
||||
(define (subst-matches matches input subst)
|
||||
(define (submatch n)
|
||||
(regexp-match-submatch matches n))
|
||||
(and
|
||||
matches
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(call-with-input-string subst
|
||||
(lambda (in)
|
||||
(let lp ()
|
||||
(let ((c (read-char in)))
|
||||
(cond
|
||||
((not (eof-object? c))
|
||||
(case c
|
||||
((#\&)
|
||||
(display (or (submatch 0) "") out))
|
||||
((#\\)
|
||||
(let ((c (read-char in)))
|
||||
(if (char-numeric? c)
|
||||
(let lp ((res (list c)))
|
||||
(if (and (char? (peek-char in))
|
||||
(char-numeric? (peek-char in)))
|
||||
(lp (cons (read-char in) res))
|
||||
(display
|
||||
(or (submatch (string->number
|
||||
(list->string (reverse res))))
|
||||
"")
|
||||
out)))
|
||||
(write-char c out))))
|
||||
(else
|
||||
(write-char c out)))
|
||||
(lp)))))))))))
|
||||
(let ()
|
||||
(define (subst-matches matches input subst)
|
||||
(define (submatch n)
|
||||
(regexp-match-submatch matches n))
|
||||
(and
|
||||
matches
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(call-with-input-string subst
|
||||
(lambda (in)
|
||||
(let lp ()
|
||||
(let ((c (read-char in)))
|
||||
(cond
|
||||
((not (eof-object? c))
|
||||
(case c
|
||||
((#\&)
|
||||
(display (or (submatch 0) "") out))
|
||||
((#\\)
|
||||
(let ((c (read-char in)))
|
||||
(if (char-numeric? c)
|
||||
(let lp ((res (list c)))
|
||||
(if (and (char? (peek-char in))
|
||||
(char-numeric? (peek-char in)))
|
||||
(lp (cons (read-char in) res))
|
||||
(display
|
||||
(or (submatch (string->number
|
||||
(list->string (reverse res))))
|
||||
"")
|
||||
out)))
|
||||
(write-char c out))))
|
||||
(else
|
||||
(write-char c out)))
|
||||
(lp)))))))))))
|
||||
|
||||
(define (test-pcre line)
|
||||
(match (string-split line #\tab)
|
||||
((pattern input result subst output)
|
||||
(let ((name (string-append pattern " " input " " result " " subst)))
|
||||
(cond
|
||||
((equal? "c" result)
|
||||
(test-error name (regexp-search (pcre->sre pattern) input)))
|
||||
((equal? "n" result)
|
||||
(test-assert name (not (regexp-search (pcre->sre pattern) input))))
|
||||
(else
|
||||
(test name output
|
||||
(subst-matches (regexp-search (pcre->sre pattern) input)
|
||||
input
|
||||
subst))))))
|
||||
(else
|
||||
(error "invalid regex test line" line))))
|
||||
(define (test-pcre line)
|
||||
(match (string-split line #\tab)
|
||||
((pattern input result subst output)
|
||||
(let ((name (string-append pattern " " input " " result " " subst)))
|
||||
(cond
|
||||
((equal? "c" result)
|
||||
(test-error name (regexp-search (pcre->sre pattern) input)))
|
||||
((equal? "n" result)
|
||||
(test-assert name (not (regexp-search (pcre->sre pattern) input))))
|
||||
(else
|
||||
(test name output
|
||||
(subst-matches (regexp-search (pcre->sre pattern) input)
|
||||
input
|
||||
subst))))))
|
||||
(else
|
||||
(error "invalid regex test line" line))))
|
||||
|
||||
(test-group "pcre"
|
||||
(call-with-input-file "tests/re-tests.txt"
|
||||
(lambda (in)
|
||||
(for-each
|
||||
(lambda (line) (test-pcre line))
|
||||
(port->list read-line in)))))
|
||||
(test-group "pcre"
|
||||
(call-with-input-file "tests/re-tests.txt"
|
||||
(lambda (in)
|
||||
(for-each
|
||||
(lambda (line) (test-pcre line))
|
||||
(port->list read-line in))))))
|
||||
|
||||
(test-end))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -312,11 +311,11 @@
|
|||
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
|
||||
"#(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
|
||||
"(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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -12,21 +12,20 @@
|
|||
(chibi tar)
|
||||
(chibi test))
|
||||
(begin
|
||||
;; 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.
|
||||
(define (bv . args)
|
||||
(apply bytevector-append
|
||||
(map (lambda (x)
|
||||
(cond ((string? x) (string->utf8 x))
|
||||
((pair? x) (make-bytevector (cdr x) (car x)))
|
||||
((integer? x) (bytevector x))
|
||||
(else x)))
|
||||
args)))
|
||||
(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.
|
||||
(define (bv . args)
|
||||
(apply bytevector-append
|
||||
(map (lambda (x)
|
||||
(cond ((string? x) (string->utf8 x))
|
||||
((pair? x) (make-bytevector (cdr x) (car x)))
|
||||
((integer? x) (bytevector x))
|
||||
(else x)))
|
||||
args)))
|
||||
|
||||
(let ((b (bv "foo" '(0 . 97)
|
||||
"000644 " 0
|
||||
"000765 " 0
|
||||
|
|
|
|||
|
|
@ -4,6 +4,27 @@
|
|||
(chibi test)
|
||||
(chibi term ansi))
|
||||
(begin
|
||||
(define-syntax test-escape-procedure
|
||||
(syntax-rules ()
|
||||
((test-escape-procedure p s)
|
||||
(begin
|
||||
(test-assert (procedure? p))
|
||||
(test-error (p #f))
|
||||
(test s (p))))))
|
||||
(define-syntax test-wrap-procedure
|
||||
(syntax-rules ()
|
||||
((test-wrap-procedure p s)
|
||||
(begin
|
||||
(test-assert (procedure? p))
|
||||
(test-error (p))
|
||||
(test-error (p #f))
|
||||
(test-error (p "" #f))
|
||||
(test (p "FOO")
|
||||
"FOO"
|
||||
(parameterize ((ansi-escapes-enabled? #f)) (p "FOO")))
|
||||
(test (p "FOO")
|
||||
s
|
||||
(parameterize ((ansi-escapes-enabled? #t)) (p "FOO")))))))
|
||||
(define (run-tests)
|
||||
(test-begin "term.ansi")
|
||||
|
||||
|
|
@ -14,29 +35,6 @@
|
|||
(parameterize ((ansi-escapes-enabled? tag))
|
||||
(ansi-escapes-enabled?)))))
|
||||
|
||||
(define-syntax test-escape-procedure
|
||||
(syntax-rules ()
|
||||
((test-escape-procedure p s)
|
||||
(begin
|
||||
(test-assert (procedure? p))
|
||||
(test-error (p #f))
|
||||
(test s (p))))))
|
||||
|
||||
(define-syntax test-wrap-procedure
|
||||
(syntax-rules ()
|
||||
((test-wrap-procedure p s)
|
||||
(begin
|
||||
(test-assert (procedure? p))
|
||||
(test-error (p))
|
||||
(test-error (p #f))
|
||||
(test-error (p "" #f))
|
||||
(test (p "FOO")
|
||||
"FOO"
|
||||
(parameterize ((ansi-escapes-enabled? #f)) (p "FOO")))
|
||||
(test (p "FOO")
|
||||
s
|
||||
(parameterize ((ansi-escapes-enabled? #t)) (p "FOO")))))))
|
||||
|
||||
(test-escape-procedure black-escape "\x1b;[30m")
|
||||
(test-escape-procedure red-escape "\x1b;[31m")
|
||||
(test-escape-procedure green-escape "\x1b;[32m")
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,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))
|
||||
|
|
|
|||
|
|
@ -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,57 +112,58 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-record-type person #t #t (name) (sex) (age))
|
||||
(define-record-type (employee person) #t #t (department) (salary))
|
||||
(let ()
|
||||
(define-record-type person #t #t (name) (sex) (age))
|
||||
(define-record-type (employee person) #t #t (department) (salary))
|
||||
|
||||
(define bob (make-employee "Bob" 'male 28 'hr 50000.0))
|
||||
(define alice (make-employee "Alice" 'female 32 'research 100000.0))
|
||||
(define bob (make-employee "Bob" 'male 28 'hr 50000.0))
|
||||
(define alice (make-employee "Alice" 'female 32 'research 100000.0))
|
||||
|
||||
(test-assert (person? bob))
|
||||
(test-assert (employee? bob))
|
||||
(test "Bob" (person-name bob))
|
||||
(test 'male (person-sex bob))
|
||||
(test 28 (person-age bob))
|
||||
(test 'hr (employee-department bob))
|
||||
(test 50000.0 (employee-salary bob))
|
||||
(test-assert (person? bob))
|
||||
(test-assert (employee? bob))
|
||||
(test "Bob" (person-name bob))
|
||||
(test 'male (person-sex bob))
|
||||
(test 28 (person-age bob))
|
||||
(test 'hr (employee-department bob))
|
||||
(test 50000.0 (employee-salary bob))
|
||||
|
||||
(test-assert (person? alice))
|
||||
(test-assert (employee? alice))
|
||||
(test "Alice" (person-name alice))
|
||||
(test 'female (person-sex alice))
|
||||
(test 32 (person-age alice))
|
||||
(test 'research (employee-department alice))
|
||||
(test 100000.0 (employee-salary alice))
|
||||
(test-assert (person? alice))
|
||||
(test-assert (employee? alice))
|
||||
(test "Alice" (person-name alice))
|
||||
(test 'female (person-sex alice))
|
||||
(test 32 (person-age alice))
|
||||
(test 'research (employee-department alice))
|
||||
(test 100000.0 (employee-salary alice))
|
||||
|
||||
;; After a trip to Thailand...
|
||||
(person-sex-set! bob 'female)
|
||||
(person-name-set! bob "Roberta")
|
||||
;; After a trip to Thailand...
|
||||
(person-sex-set! bob 'female)
|
||||
(person-name-set! bob "Roberta")
|
||||
|
||||
;; Then Roberta quits!
|
||||
(employee-department-set! bob #f)
|
||||
(employee-salary-set! bob 0.0)
|
||||
;; Then Roberta quits!
|
||||
(employee-department-set! bob #f)
|
||||
(employee-salary-set! bob 0.0)
|
||||
|
||||
(test "Roberta" (person-name bob))
|
||||
(test 'female (person-sex bob))
|
||||
(test 28 (person-age bob))
|
||||
(test #f (employee-department bob))
|
||||
(test 0.0 (employee-salary bob))
|
||||
(test "Roberta" (person-name bob))
|
||||
(test 'female (person-sex bob))
|
||||
(test 28 (person-age bob))
|
||||
(test #f (employee-department bob))
|
||||
(test 0.0 (employee-salary bob))
|
||||
|
||||
;; SRFI-99 forbids this, but we currently do it anyway.
|
||||
(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
|
||||
(make-employee "Chuck" 'male 20 'janitorial 50000.0)))
|
||||
;; SRFI-99 forbids this, but we currently do it anyway.
|
||||
(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
|
||||
(make-employee "Chuck" 'male 20 'janitorial 50000.0)))
|
||||
|
||||
(test-assert (record? alice))
|
||||
(test 'person (rtd-name person))
|
||||
(let* ((constructor (rtd-constructor person))
|
||||
(trent (constructor "Trent" 'male 44)))
|
||||
(test "Trent" (person-name trent))
|
||||
(test 'male (person-sex trent))
|
||||
(test 44 ((rtd-accessor person 'age) trent))
|
||||
((rtd-mutator person 'age) trent 45)
|
||||
(test 45 (person-age trent)))
|
||||
(test-assert (record? alice))
|
||||
(test 'person (rtd-name person))
|
||||
(let* ((constructor (rtd-constructor person))
|
||||
(trent (constructor "Trent" 'male 44)))
|
||||
(test "Trent" (person-name trent))
|
||||
(test 'male (person-sex trent))
|
||||
(test 44 ((rtd-accessor person 'age) trent))
|
||||
((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,50 +173,54 @@
|
|||
;;
|
||||
;; (test-assert (not (rtd-field-mutable? foo 'x)))
|
||||
|
||||
(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)))
|
||||
(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))))
|
||||
|
||||
;; Name conflicts - make sure we rename
|
||||
|
||||
(define-record-type example make-example #t example)
|
||||
(test-assert (example? (make-example 3)))
|
||||
(test 3 (example-example (make-example 3)))
|
||||
(let ()
|
||||
(define-record-type example make-example #t example)
|
||||
(test-assert (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
|
||||
|
||||
(define-record-type abstract
|
||||
#f #t)
|
||||
(let ()
|
||||
(define-record-type abstract
|
||||
#f #t)
|
||||
|
||||
(test #f (memq 'make-abstract (env-exports (current-environment))))
|
||||
(define-record-type (derived abstract)
|
||||
#t #f)
|
||||
|
||||
(define-record-type (derived abstract)
|
||||
#t #f)
|
||||
(define instance (make-derived))
|
||||
|
||||
(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)))))
|
||||
|
||||
(define-record-type container
|
||||
#t #t
|
||||
default-immutable
|
||||
(default-mutable)
|
||||
(named-immutable get-container-immutable)
|
||||
(named-mutable get-container-mutable set-container-mutable!))
|
||||
(let ()
|
||||
(define-record-type container
|
||||
#t #t
|
||||
default-immutable
|
||||
(default-mutable)
|
||||
(named-immutable get-container-immutable)
|
||||
(named-mutable get-container-mutable set-container-mutable!))
|
||||
|
||||
(define container-instance (make-container 1 2 3 4))
|
||||
(define container-instance (make-container 1 2 3 4))
|
||||
|
||||
(test 1 (container-default-immutable container-instance))
|
||||
(test 2 (container-default-mutable container-instance))
|
||||
(test 3 (get-container-immutable container-instance))
|
||||
(test 4 (get-container-mutable container-instance))
|
||||
(test 1 (container-default-immutable container-instance))
|
||||
(test 2 (container-default-mutable container-instance))
|
||||
(test 3 (get-container-immutable container-instance))
|
||||
(test 4 (get-container-mutable container-instance))
|
||||
|
||||
(container-default-mutable-set! container-instance #t)
|
||||
(test #t (container-default-mutable container-instance))
|
||||
(container-default-mutable-set! container-instance #t)
|
||||
(test #t (container-default-mutable container-instance))
|
||||
|
||||
(set-container-mutable! container-instance #t)
|
||||
(test #t (get-container-mutable container-instance))
|
||||
(set-container-mutable! container-instance #t)
|
||||
(test #t (get-container-mutable container-instance)))
|
||||
|
||||
(test-end))))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue