~ chicken-r7rs (master) cf93413cd1380fe07452c7f162871fab7ce248f8

commit cf93413cd1380fe07452c7f162871fab7ce248f8
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sun Jul 28 17:10:28 2013 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jul 28 17:10:28 2013 +0000

    Reverse, list-tail, list-ref and list-set!

diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 41014ba..3ac77e0 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -102,18 +102,15 @@
   letrec letrec*
   let-values let*-values
   |#
-  let-syntax
-  letrec-syntax
+  let-syntax letrec-syntax
   #|
   library                    ; for "cond-expand"
   |#
   list
   #|
   list-copy
-  list-ref list-set!
-  list-tail
   |#
-  list?
+  list-ref list-set! list-tail list?
   #|
   make-bytevector
   |#
@@ -161,7 +158,9 @@
   read-string
   read-u8
   real?
+  |#
   reverse
+  #|
   round
   set!
   |#
diff --git a/scheme.base.scm b/scheme.base.scm
index c7e4f1d..e6778a7 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -134,10 +134,36 @@
    ((n fill)
     (##sys#check-integer n 'make-list)
     (unless (fx>= n 0)
-      (error 'make-list "Not a positive integer" n))
+      (error 'make-list "not a positive integer" n))
     (do ((i n (fx- i 1))
          (result '() (cons fill result)))
-        ((fx<= i 0) result))))) 
+        ((fx= i 0) result)))))
+
+
+(: list-tail (forall (x) ((list-of x) fixnum -> (list-of x))))
+
+(define (list-tail l n)
+  (##sys#check-integer n 'list-tail)
+  (unless (fx>= n 0)
+    (error 'list-tail "not a positive integer" n))
+  (do ((i n (fx- i 1))
+       (result l (cdr result)))
+      ((fx= i 0) result)
+    (when (null? result)
+      (error 'list-tail "out of range"))))
+
+
+(: list-set! (list fixnum -> undefined))
+
+(define (list-set! l n obj)
+  (##sys#check-integer n 'list-set!)
+  (unless (fx>= n 0)
+    (error 'list-set! "not a positive integer" n))
+  (do ((i n (fx- i 1))
+       (l l (cdr l)))
+      ((fx= i 0) (set-car! l obj))
+    (when (null? l)
+      (error 'list-set! "out of range"))))
 
 ;;;
 ;;; 6.11. Exceptions
diff --git a/tests/run.scm b/tests/run.scm
index e017064..08164b8 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -162,7 +162,42 @@
     (test 'a (append '() 'a))
     (test '(a b . c) (append '(a b) 'c))
     (test-error (append 'x '()))
-    (test-error (append '(x) 'y '()))))
+    (test-error (append '(x) 'y '())))
+
+  (test-group "reverse"
+    (test '(c b a) (reverse '(a b c)))
+    (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+    (test '() (reverse '()))
+    (test-error (reverse '(a . b)))
+    (test-error (reverse '(a b) '(c d)))
+    (test-error (reverse 'a))
+    (test-error (reverse '#(a b c)))
+    (test-error (reverse "foo")))
+
+  (test-group "list-tail"
+    (test '(a b c d e f) (list-tail '(a b c d e f) 0))
+    (test '(d e f) (list-tail '(a b c d e f) 3))
+    (test '() (list-tail '(a b c d e f) 6))
+    (test '() (list-tail '() 0))
+    (test-error (list-tail '(a b c d e f) -1))
+    (test-error (list-tail '(a b c d e f) 7))
+    (test-error (list-tail '(a b c d e . f) 6)))
+
+  (test-group "list-ref"
+    (test 'a (list-ref '(a b c d) 0))
+    (test 'b (list-ref '(a b c d) 1))
+    (test 'c (list-ref '(a b c d) 2))
+    (test 'd (list-ref '(a b c d) 3))
+    (test-error (list-ref '(a b c d) 4))
+    (test-error (list-ref '(a b c d) -1)))
+
+  (test-group "list-set!"
+    (let ((ls (list 'one 'two 'five!)))
+      (list-set! ls 2 'three)
+      (test '(two three) (cdr ls)))
+    ;; Should be an error?
+    #;(list-set! '(0 1 2) 1 "oops")
+    ))
 
 (define-syntax catch
   (syntax-rules ()