~ chicken-r7rs (master) 5a06d80976e1be4de98e368ee54c8c0e6f1ee91a
commit 5a06d80976e1be4de98e368ee54c8c0e6f1ee91a
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Jul 28 16:10:15 2013 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jul 28 16:10:15 2013 +0000
Add tests for several list/pair procedures, and re-export them (plus implement make-list)
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index af87a3b..41014ba 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -4,7 +4,9 @@
<= < >= = >
abs
and
+ |#
append
+ #|
apply
assoc assq assv
begin
@@ -15,7 +17,10 @@
bytevector-append bytevector-copy bytevector-copy!
bytevector-length bytevector-u8-ref bytevector-u8-set!
bytevector?
- car cdr caar cadr cdar
+ |#
+ car cdr
+ caar cadr cdar cddr
+ #|
call-with-current-continuation call/cc
|#
call-with-port
@@ -35,8 +40,8 @@
cond
|#
cond-expand
- #|
cons
+ #|
current-input-port current-output-port current-error-port
define
define-record-type
@@ -90,7 +95,9 @@
input-port? output-port?
integer?
lambda
+ |#
length
+ #|
let let*
letrec letrec*
let-values let*-values
@@ -99,13 +106,19 @@
letrec-syntax
#|
library ; for "cond-expand"
+ |#
list
+ #|
list-copy
list-ref list-set!
list-tail
+ |#
list?
+ #|
make-bytevector
+ |#
make-list
+ #|
make-parameter
make-string
make-vector
@@ -117,13 +130,15 @@
newline
|#
not
- #|
null?
+ #|
number->string string->number
number?
open-input-bytevector open-output-bytevector
open-input-string open-output-string
+ |#
pair?
+ #|
parameterize
peek-char
peek-u8
@@ -149,7 +164,9 @@
reverse
round
set!
+ |#
set-car! set-cdr!
+ #|
square
string
string->list list->string
diff --git a/scheme.base.scm b/scheme.base.scm
index d49c81c..c7e4f1d 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -122,6 +122,23 @@
(lp b2 (car rest) (cdr rest) (and result (eq? b1 b2))))))
+;;;
+;;; 6.4 pairs and lists
+;;;
+
+(: make-list (forall (x) (fixnum #!optional x -> (list-of x))))
+
+(define make-list
+ (case-lambda
+ ((n) (make-list n #f))
+ ((n fill)
+ (##sys#check-integer n 'make-list)
+ (unless (fx>= n 0)
+ (error 'make-list "Not a positive integer" n))
+ (do ((i n (fx- i 1))
+ (result '() (cons fill result)))
+ ((fx<= i 0) result)))))
+
;;;
;;; 6.11. Exceptions
;;;
diff --git a/tests/run.scm b/tests/run.scm
index 4be5c94..e017064 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -10,30 +10,159 @@
(test-begin "r7rs tests")
-(test-group "long boolean literals"
- (test #t (read-from-string "#t"))
- (test #f (read-from-string "#f"))
- (test #t (read-from-string "#true"))
- (test #f (read-from-string "#false"))
- (test-error (read-from-string "#faux")))
-
-(test-group "boolean=?"
- (test #t (boolean=? #t #t))
- (test #t (boolean=? #t #t #t #t))
- (test #t (boolean=? #f #f))
- (test #t (boolean=? #f #f #f #f))
- (test #f (boolean=? #f #t))
- (test #f (boolean=? #f #t #t #t))
- (test #f (boolean=? #f #f #t #t))
- (test #f (boolean=? #f #f #f #t))
- (test #f (boolean=? #t #f #f #f))
- (test #f (boolean=? #t #f #f #t))
- (test #f (boolean=? #t #t #f #t))
- (test #f (boolean=? #f #f #f #t))
- (test #f (boolean=? #f #t #f #f))
- (test-error (boolean=? #f))
- (test-error (boolean=? #f 1))
- (test-error "no shortcutting" (boolean=? #f #t 2)))
+(test-group "6.3: booleans"
+ (test-group "long boolean literals"
+ (test #t (read-from-string "#t"))
+ (test #f (read-from-string "#f"))
+ (test #t (read-from-string "#true"))
+ (test #f (read-from-string "#false"))
+ (test-error (read-from-string "#faux")))
+
+ (test-group "boolean=?"
+ (test #t (boolean=? #t #t))
+ (test #t (boolean=? #t #t #t #t))
+ (test #t (boolean=? #f #f))
+ (test #t (boolean=? #f #f #f #f))
+ (test #f (boolean=? #f #t))
+ (test #f (boolean=? #f #t #t #t))
+ (test #f (boolean=? #f #f #t #t))
+ (test #f (boolean=? #f #f #f #t))
+ (test #f (boolean=? #t #f #f #f))
+ (test #f (boolean=? #t #f #f #t))
+ (test #f (boolean=? #t #t #f #t))
+ (test #f (boolean=? #f #f #f #t))
+ (test #f (boolean=? #f #t #f #f))
+ (test-error (boolean=? #f))
+ (test-error (boolean=? #f 1))
+ (test-error "no shortcutting" (boolean=? #f #t 2))))
+
+(test-group "6.4: pairs and lists"
+ (test-group "pair?"
+ (test #t (pair? '(a . b)))
+ (test #t (pair? '(a b c)))
+ (test #f (pair? '()))
+ (test #f (pair? '#(a b)))
+ (test #f (pair? #f))
+ (test #f (pair? #t))
+ (test #f (pair? "some string"))
+ (test #f (pair? 123)))
+
+ (test-group "cons"
+ (test '(a) (cons 'a '()))
+ (test '((a) b c d) (cons '(a) '(b c d)))
+ (test '("a" b c) (cons "a" '(b c)))
+ (test '(a . 3) (cons 'a 3))
+ (test '((a b) . c) (cons '(a b) 'c)))
+
+ (test-group "car"
+ (test 'a (car '(a b c)))
+ (test '(a) (car '((a) b c d)))
+ (test 1 (car '(1 . 2)))
+ (test-error (car '()))
+ (test-error (car '#(1 2 3)))
+ (test-error (car "not a pair")))
+
+ (test-group "cdr"
+ (test '(b c d) (cdr '((a) b c d)))
+ (test 2 (cdr '(1 . 2)))
+ (test-error (cdr '()))
+ (test-error (cdr '#(1 2 3)))
+ (test-error (cdr "not a pair")))
+
+ (test-group "set-car!"
+ (define (f) (list 'not-a-constant-list))
+ (define (g) '(constant-list))
+ ;; Examples from the text are very incomplete and strange
+ (let ((res (f)))
+ (set-car! res 2)
+ (test 2 (car res))
+ (set-car! (f) 3)
+ (test 'not-a-constant-list (car (f))))
+ ;; XXX Should this *raise* an error? R5RS also says this it "is an error"
+ #;(test-error (set-car! (g) 3))
+ (test-error (set-car! 'x 'y)))
+
+ (test-group "set-cdr!"
+ (define (f) (list 'not-a-constant-list))
+ (define (g) '(constant-list))
+ ;; Examples from the text are very incomplete and strange
+ (let ((res (f)))
+ (set-cdr! res 2)
+ (test 2 (cdr res))
+ (set-cdr! (f) 3)
+ (test '() (cdr (f))))
+ ;; XXX Should this *raise* an error? R5RS also says this it "is an error"
+ #;(test-error (set-cdr! (g) 3))
+ (test-error (set-cdr! 'x 'y)))
+
+ (test-group "c..r (base)"
+ (test 'x (caar '((x) y)))
+ (test-error (caar '(x y)))
+ (test 'y (cadr '((x) y)))
+ (test-error (cadr '(x)))
+ (test '() (cdar '((x) y)))
+ (test-error (cdar '(x)))
+ (test '() (cddr '((x) y)))
+ (test-error (cddr '(x))))
+
+ ;; TODO: c..r (cxr)
+
+ (test-group "null?"
+ (test #t (null? '()))
+ (test #t (null? (list)))
+ (test #f (null? '(a)))
+ (test #f (null? 'a))
+ (test #f (null? '#()))
+ (test #f (null? "foo")))
+
+ (test-group "list?"
+ (test #t (list? '(a b c)))
+ (test #t (list? (list 'a 'b 'c)))
+ (test #t (list? '()))
+ (test #f (list? '(a . b)))
+ (let ((x (list 'a)))
+ (set-cdr! x x)
+ (test #f (list? x)))
+ (test #f (list? 'a))
+ (test #f (list? '#()))
+ (test #f (list? "foo")))
+
+ (test-group "make-list"
+ (test-error (make-list))
+ (test '() (make-list 0))
+ (test '(#f) (make-list 1)) ; Unspecified
+
+ (test '(#f) (make-list 1 #f))
+ (test-error (make-list 1 2 3))
+ (test '(3 3) (make-list 2 3))
+ (test '() (make-list 0 3))
+ (test-error (make-list -1 3))
+ (test-error (make-list #f 3)))
+
+ (test-group "list"
+ (test '(a 7 c) (list 'a (+ 3 4) 'c))
+ (test '() (list))
+ (test '(#f) (list #f))
+ (test '(a b c) (list 'a 'b 'c)))
+
+ (test-group "length"
+ (test 3 (length '(a b c)))
+ (test 3 (length '(a (b) (c d e))))
+ (test 0 (length '()))
+
+ (test-error (length '(x . y)))
+ (test-error (length '#(x y)))
+ (test-error (length "foo")))
+
+ (test-group "append"
+ (test '(x y) (append '(x) '(y)))
+ (test '(a b c d) (append '(a) '(b c d)))
+ (test '(a (b) (c)) (append '(a (b)) '((c))))
+ (test '(a b c . d) (append '(a b) '(c . d)))
+ (test 'a (append '() 'a))
+ (test '(a b . c) (append '(a b) 'c))
+ (test-error (append 'x '()))
+ (test-error (append '(x) 'y '()))))
(define-syntax catch
(syntax-rules ()
Trap