Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +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

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

@ -6,39 +6,6 @@
(chibi test)) (chibi test))
(begin (begin
(define (run-tests) (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) (define (test-key key)
(test #t (rsa-key? key)) (test #t (rsa-key? key))
@ -47,6 +14,37 @@
(test #t (positive? (rsa-key-d key))) (test #t (positive? (rsa-key-d key)))
(test 5 (rsa-decrypt key (rsa-encrypt (rsa-pub-key key) 5)))) (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 8))
(test-key (rsa-key-gen 16)) (test-key (rsa-key-gen 16))
(test-key (rsa-key-gen 32)) (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)) (only (chibi test) test-begin test test-end))
(begin (begin
(define (run-tests) (define (run-tests)
(test-begin "io")
(define long-string (make-string 2000 #\a)) (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 (test "input-string-port" 1025
(call-with-input-string (substring long-string 0 1025) (call-with-input-string (substring long-string 0 1025)
(lambda (in) (lambda (in)
@ -78,9 +89,6 @@
(close-input-port in) (close-input-port in)
res))) res)))
(define (string-upcase str)
(list->string (map char-upcase (string->list str))))
(test "upcase-input-port" "ABC" (test "upcase-input-port" "ABC"
(call-with-input-string "abc" (call-with-input-string "abc"
(lambda (in) (lambda (in)
@ -96,14 +104,6 @@
(display "abc" out) (display "abc" out)
(close-output-port 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 '("abcdef"))))
(test "abcdef" (read-line (strings->input-port '("abc" "def")))) (test "abcdef" (read-line (strings->input-port '("abc" "def"))))
(test "abcdef" (test "abcdef"

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

@ -2,6 +2,13 @@
(export run-tests) (export run-tests)
(import (chibi) (chibi loop) (only (chibi test) test-begin test test-end)) (import (chibi) (chibi loop) (only (chibi test) test-begin test test-end))
(begin (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) (define (run-tests)
(test-begin "loops") (test-begin "loops")
@ -55,14 +62,6 @@
(for res (listing ls))) (for res (listing ls)))
=> res)) => 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 (test
"flatten (recursion test)" "flatten (recursion test)"
'(1 2 3 4 5 6 7) '(1 2 3 4 5 6 7)

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

@ -3,6 +3,15 @@
(import (except (scheme base) equal?) (import (except (scheme base) equal?)
(chibi match) (chibi match)
(only (chibi test) test-begin test test-end)) (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 (begin
(define (run-tests) (define (run-tests)
(test-begin "match") (test-begin "match")
@ -179,11 +188,6 @@
(cond-expand (cond-expand
(chibi (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" (test "record positional"
'(1 0) '(1 0)
(match (make-point 0 1) (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))) (list x (+ 1 x) (+ -1 x) (- x) (- 1 x) (- -1 x)))
(define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1))))) (define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1)))))
(define (atanh z) (/ (- (log (+ 1 z)) (log (- 1 z))) 2)) (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) (define (run-tests)
(test-begin "numbers") (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 ;; fix x fix
(test '((1 -1 0 0 0) (1 -1 0 0 0) (-1 1 0 0 0) (-1 1 0 0 0)) (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)) (sign-combinations 0 1))
@ -136,8 +134,6 @@
4294967296 -1)) 4294967296 -1))
(sign-combinations (+ 1 (expt 2 64)) (expt 2 32))) (sign-combinations (+ 1 (expt 2 64)) (expt 2 32)))
(define M7 (- (expt 2 127) 1))
(test '((170141183460469231750134047789593657344 (test '((170141183460469231750134047789593657344
170141183460469231713240559642174554110 170141183460469231713240559642174554110
3138550867693340382088035895064302439764418281874191810559 3138550867693340382088035895064302439764418281874191810559
@ -158,7 +154,7 @@
3138550867693340382088035895064302439764418281874191810559 3138550867693340382088035895064302439764418281874191810559
9223372036854775807 9223372036854775807
-9223372036854775808)) -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 ;; fixnum-bignum boundaries (machine word - 1 bit for sign - 2
;; bits for tag) ;; bits for tag)

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

@ -224,61 +224,62 @@
(regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 4)) (regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 4))
(test " abc d ef " (regexp-replace-all '(+ space) " abc \t\n d ef " " ")) (test " abc d ef " (regexp-replace-all '(+ space) " abc \t\n d ef " " "))
(define (subst-matches matches input subst) (let ()
(define (submatch n) (define (subst-matches matches input subst)
(regexp-match-submatch matches n)) (define (submatch n)
(and (regexp-match-submatch matches n))
matches (and
(call-with-output-string matches
(lambda (out) (call-with-output-string
(call-with-input-string subst (lambda (out)
(lambda (in) (call-with-input-string subst
(let lp () (lambda (in)
(let ((c (read-char in))) (let lp ()
(cond (let ((c (read-char in)))
((not (eof-object? c)) (cond
(case c ((not (eof-object? c))
((#\&) (case c
(display (or (submatch 0) "") out)) ((#\&)
((#\\) (display (or (submatch 0) "") out))
(let ((c (read-char in))) ((#\\)
(if (char-numeric? c) (let ((c (read-char in)))
(let lp ((res (list c))) (if (char-numeric? c)
(if (and (char? (peek-char in)) (let lp ((res (list c)))
(char-numeric? (peek-char in))) (if (and (char? (peek-char in))
(lp (cons (read-char in) res)) (char-numeric? (peek-char in)))
(display (lp (cons (read-char in) res))
(or (submatch (string->number (display
(list->string (reverse res)))) (or (submatch (string->number
"") (list->string (reverse res))))
out))) "")
(write-char c out)))) out)))
(else (write-char c out))))
(write-char c out))) (else
(lp))))))))))) (write-char c out)))
(lp)))))))))))
(define (test-pcre line) (define (test-pcre line)
(match (string-split line #\tab) (match (string-split line #\tab)
((pattern input result subst output) ((pattern input result subst output)
(let ((name (string-append pattern " " input " " result " " subst))) (let ((name (string-append pattern " " input " " result " " subst)))
(cond (cond
((equal? "c" result) ((equal? "c" result)
(test-error name (regexp-search (pcre->sre pattern) input))) (test-error name (regexp-search (pcre->sre pattern) input)))
((equal? "n" result) ((equal? "n" result)
(test-assert name (not (regexp-search (pcre->sre pattern) input)))) (test-assert name (not (regexp-search (pcre->sre pattern) input))))
(else (else
(test name output (test name output
(subst-matches (regexp-search (pcre->sre pattern) input) (subst-matches (regexp-search (pcre->sre pattern) input)
input input
subst)))))) subst))))))
(else (else
(error "invalid regex test line" line)))) (error "invalid regex test line" line))))
(test-group "pcre" (test-group "pcre"
(call-with-input-file "tests/re-tests.txt" (call-with-input-file "tests/re-tests.txt"
(lambda (in) (lambda (in)
(for-each (for-each
(lambda (line) (test-pcre line)) (lambda (line) (test-pcre line))
(port->list read-line in))))) (port->list read-line in))))))
(test-end)))) (test-end))))

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

@ -3,6 +3,11 @@
(import (scheme base) (scheme read) (chibi test) (import (scheme base) (scheme read) (chibi test)
(chibi show) (chibi show base) (chibi show pretty)) (chibi show) (chibi show base) (chibi show pretty))
(begin (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) (define (run-tests)
(test-begin "show") (test-begin "show")
@ -288,12 +293,6 @@
;; pretty printing ;; 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 "(foo bar)\n")
(test-pretty (test-pretty
@ -312,11 +311,11 @@
wubbleflubbery)\n") wubbleflubbery)\n")
'(test-pretty '(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") 26 27 28 29 30 31 32 33 34 35 36 37)\n")
'(test-pretty '(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") 26 27 28 29 30 31 32 33 34 35 36 37)\n")
(test-pretty (test-pretty

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

@ -27,9 +27,9 @@
;; stress test user-name ;; stress test user-name
(test (user-name (user-information (current-user-id))) (test (user-name (user-information (current-user-id)))
(user-name (user-information (current-user-id)))) (user-name (user-information (current-user-id))))
(define u (user-information (current-user-id))) (let ((u (user-information (current-user-id))))
(test (user-name u) (user-name (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)))) (let ((un (user-name (user-information (current-user-id)))))
(test un (user-name (user-information (current-user-id)))) (test un (user-name (user-information (current-user-id)))))
(test-end)))) (test-end))))

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

@ -12,21 +12,20 @@
(chibi tar) (chibi tar)
(chibi test)) (chibi test))
(begin (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) (define (run-tests)
(test-begin "tar") (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) (let ((b (bv "foo" '(0 . 97)
"000644 " 0 "000644 " 0
"000765 " 0 "000765 " 0

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

@ -4,6 +4,27 @@
(chibi test) (chibi test)
(chibi term ansi)) (chibi term ansi))
(begin (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) (define (run-tests)
(test-begin "term.ansi") (test-begin "term.ansi")
@ -14,29 +35,6 @@
(parameterize ((ansi-escapes-enabled? tag)) (parameterize ((ansi-escapes-enabled? tag))
(ansi-escapes-enabled?))))) (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 black-escape "\x1b;[30m")
(test-escape-procedure red-escape "\x1b;[31m") (test-escape-procedure red-escape "\x1b;[31m")
(test-escape-procedure green-escape "\x1b;[32m") (test-escape-procedure green-escape "\x1b;[32m")

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

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

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

@ -5,9 +5,9 @@
(chibi test)) (chibi test))
(begin (begin
(define (run-tests) (define (run-tests)
(test-begin "srfi-27: random")
(define (test-random rand n) (define (test-random rand n)
(test-assert (<= 0 (rand n) (- n 1)))) (test-assert (<= 0 (rand n) (- n 1))))
(test-begin "srfi-27: random")
(let ((rs (make-random-source))) (let ((rs (make-random-source)))
;; chosen by fair dice roll. guaranteed to be random ;; chosen by fair dice roll. guaranteed to be random
(random-source-pseudo-randomize! rs 4 4) (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)) (import (chibi) (chibi test) (srfi 1) (srfi 38))
(begin (begin
(define (run-tests) (define (run-tests)
(test-begin "srfi-38: shared read/write")
(define (read-from-string str) (define (read-from-string str)
(call-with-input-string str (call-with-input-string str
(lambda (in) (read/ss in)))) (lambda (in) (read/ss in))))
@ -29,6 +27,8 @@
(test str (write-to-string value #t)) (test str (write-to-string value #t))
(test str (write-to-string (read-from-string str) #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)" (list 1))
(test-io "(1 2)" (list 1 2)) (test-io "(1 2)" (list 1 2))
(test-io "(1 . 2)" (cons 1 2)) (test-io "(1 . 2)" (cons 1 2))

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

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

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

@ -5,8 +5,6 @@
(only (chibi test) test-begin test-assert test test-end)) (only (chibi test) test-begin test-assert test test-end))
(begin (begin
(define (run-tests) (define (run-tests)
(test-begin "srfi-99: records")
(define-record-type organism (define-record-type organism
(make-organism name) (make-organism name)
organism? organism?
@ -72,6 +70,8 @@
(define mickey (make-mouse "Mickey" "cheese" 10)) (define mickey (make-mouse "Mickey" "cheese" 10))
(define felix (make-cat "Felix" mickey 8 'mixed '(and black white))) (define felix (make-cat "Felix" mickey 8 'mixed '(and black white)))
(test-begin "srfi-99: records")
(test-assert (organism? mickey)) (test-assert (organism? mickey))
(test-assert (animal? mickey)) (test-assert (animal? mickey))
(test-assert (chordate? mickey)) (test-assert (chordate? mickey))
@ -112,57 +112,58 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record-type person #t #t (name) (sex) (age)) (let ()
(define-record-type (employee person) #t #t (department) (salary)) (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 bob (make-employee "Bob" 'male 28 'hr 50000.0))
(define alice (make-employee "Alice" 'female 32 'research 100000.0)) (define alice (make-employee "Alice" 'female 32 'research 100000.0))
(test-assert (person? bob)) (test-assert (person? bob))
(test-assert (employee? bob)) (test-assert (employee? bob))
(test "Bob" (person-name bob)) (test "Bob" (person-name bob))
(test 'male (person-sex bob)) (test 'male (person-sex bob))
(test 28 (person-age bob)) (test 28 (person-age bob))
(test 'hr (employee-department bob)) (test 'hr (employee-department bob))
(test 50000.0 (employee-salary bob)) (test 50000.0 (employee-salary bob))
(test-assert (person? alice)) (test-assert (person? alice))
(test-assert (employee? alice)) (test-assert (employee? alice))
(test "Alice" (person-name alice)) (test "Alice" (person-name alice))
(test 'female (person-sex alice)) (test 'female (person-sex alice))
(test 32 (person-age alice)) (test 32 (person-age alice))
(test 'research (employee-department alice)) (test 'research (employee-department alice))
(test 100000.0 (employee-salary alice)) (test 100000.0 (employee-salary alice))
;; After a trip to Thailand... ;; After a trip to Thailand...
(person-sex-set! bob 'female) (person-sex-set! bob 'female)
(person-name-set! bob "Roberta") (person-name-set! bob "Roberta")
;; Then Roberta quits! ;; Then Roberta quits!
(employee-department-set! bob #f) (employee-department-set! bob #f)
(employee-salary-set! bob 0.0) (employee-salary-set! bob 0.0)
(test "Roberta" (person-name bob)) (test "Roberta" (person-name bob))
(test 'female (person-sex bob)) (test 'female (person-sex bob))
(test 28 (person-age bob)) (test 28 (person-age bob))
(test #f (employee-department bob)) (test #f (employee-department bob))
(test 0.0 (employee-salary bob)) (test 0.0 (employee-salary bob))
;; SRFI-99 forbids this, but we currently do it anyway. ;; SRFI-99 forbids this, but we currently do it anyway.
(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0) (test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
(make-employee "Chuck" 'male 20 'janitorial 50000.0))) (make-employee "Chuck" 'male 20 'janitorial 50000.0)))
(test-assert (record? alice)) (test-assert (record? alice))
(test 'person (rtd-name person)) (test 'person (rtd-name person))
(let* ((constructor (rtd-constructor person)) (let* ((constructor (rtd-constructor person))
(trent (constructor "Trent" 'male 44))) (trent (constructor "Trent" 'male 44)))
(test "Trent" (person-name trent)) (test "Trent" (person-name trent))
(test 'male (person-sex trent)) (test 'male (person-sex trent))
(test 44 ((rtd-accessor person 'age) trent)) (test 44 ((rtd-accessor person 'age) trent))
((rtd-mutator person 'age) trent 45) ((rtd-mutator person 'age) trent 45)
(test 45 (person-age trent))) (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. ;; We do not retain mutability information ATM.
;; (define-record-type foo ;; (define-record-type foo
@ -172,50 +173,54 @@
;; ;;
;; (test-assert (not (rtd-field-mutable? foo 'x))) ;; (test-assert (not (rtd-field-mutable? foo 'x)))
(define point (make-rtd "point" #(x y))) (let ()
(define make-point (rtd-constructor point #(x y))) (define point (make-rtd "point" #(x y)))
(define point-x (rtd-accessor point 'x)) (define make-point (rtd-constructor point #(x y)))
(test 3 (point-x (make-point 3 2))) (define point-x (rtd-accessor point 'x))
(test 3 (point-x (make-point 3 2))))
;; Name conflicts - make sure we rename ;; Name conflicts - make sure we rename
(define-record-type example make-example #t example) (let ()
(test-assert (example? (make-example 3))) (define-record-type example make-example #t example)
(test 3 (example-example (make-example 3))) (test-assert (example? (make-example 3)))
(test 3 (example-example (make-example 3))))
;; record types definitions with #f passed as either the constructor or ;; record types definitions with #f passed as either the constructor or
;; predicate argument should not create the corresponding function ;; predicate argument should not create the corresponding function
(define-record-type abstract (let ()
#f #t) (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) (define instance (make-derived))
#t #f)
(define instance (make-derived)) (test #f (memq 'make-abstract (env-exports (current-environment))))
(test-assert (abstract? instance)) (test-assert (abstract? instance))
(test #f (memq 'derived? (env-exports (current-environment)))) (test #f (memq 'derived? (env-exports (current-environment)))))
(define-record-type container (let ()
#t #t (define-record-type container
default-immutable #t #t
(default-mutable) default-immutable
(named-immutable get-container-immutable) (default-mutable)
(named-mutable get-container-mutable set-container-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 1 (container-default-immutable container-instance))
(test 2 (container-default-mutable container-instance)) (test 2 (container-default-mutable container-instance))
(test 3 (get-container-immutable container-instance)) (test 3 (get-container-immutable container-instance))
(test 4 (get-container-mutable container-instance)) (test 4 (get-container-mutable container-instance))
(container-default-mutable-set! container-instance #t) (container-default-mutable-set! container-instance #t)
(test #t (container-default-mutable container-instance)) (test #t (container-default-mutable container-instance))
(set-container-mutable! container-instance #t) (set-container-mutable! container-instance #t)
(test #t (get-container-mutable container-instance)) (test #t (get-container-mutable container-instance)))
(test-end)))) (test-end))))