adding (srfi 101)

AUTHORS

@@ -14,6 +14,9 @@ The (scheme time) module includes code for handling leap seconds
 from Alan Watson's Scheme clock library at
 http://code.google.com/p/scheme-clock/ under the same license.
 
+The (srfi 101) library is adapted from the reference implementation
+by David van Horn.
+
 The benchmarks are based on the Racket versions of the classic
 Gabriel benchmarks from
 http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html.

COPYING

@@ -1,4 +1,4 @@
-Copyright (c) 2009-2015 Alex Shinn
+Copyright (c) 2009-2018 Alex Shinn
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

doc/chibi.scrbl

@@ -1195,6 +1195,7 @@ snow-fort):
 \item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-101/srfi-101.html"]{(srfi 101) - purely functional random-access pairs and lists}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-111/srfi-111.html"]{(srfi 111) - boxes}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-113/srfi-113.html"]{(srfi 113) - sets and bags}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-115/srfi-115.html"]{(srfi 115) - Scheme regular expressions}}
@@ -1203,6 +1204,7 @@ snow-fort):
 \item{\hyperlink["http://srfi.schemers.org/srfi-121/srfi-121.html"]{(srfi 121) - generators}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-124/srfi-124.html"]{(srfi 124) - ephemerons}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-125/srfi-125.html"]{(srfi 125) - intermediate hash tables}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-127/srfi-127.html"]{(srfi 127) - lazy sequences}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-128/srfi-128.html"]{(srfi 128) - comparators (reduced)}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-129/srfi-129.html"]{(srfi 129) - titlecase procedures}}
 \item{\hyperlink["http://srfi.schemers.org/srfi-130/srfi-130.html"]{(srfi 130) - cursor-based string library}}

lib/srfi/101.scm

@@ -0,0 +1,459 @@
+;; Adapted for R7RS by Alex Shinn 2018.
+
+;; SRFI 101: Purely Functional Random-Access Pairs and Lists
+;; Copyright (c) David Van Horn 2009.  All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. REMEMBER, THERE IS NO SCHEME UNDERGROUND. IN NO EVENT
+;; SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+;; DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
+;; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(define-record-type kons
+  (make-kons size tree rest)
+  kons?
+  (size kons-size)
+  (tree kons-tree)
+  (rest kons-rest))
+
+(define-record-type node
+  (make-node val left right)
+  node?
+  (val node-val)
+  (left node-left)
+  (right node-right))
+
+(define-syntax assert
+  (syntax-rules ()
+    ((assert expr ...)
+     (begin (unless expr (error "assertion failed" 'expr)) ...))))
+
+;; Nat -> Nat
+(define (sub1 n) (- n 1))
+(define (add1 n) (+ n 1))
+
+;; [Tree X] -> X
+(define (tree-val t)
+  (if (node? t) 
+      (node-val t)
+      t))
+
+;; [X -> Y] [Tree X] -> [Tree Y]
+(define (tree-map f t)
+  (if (node? t)
+      (make-node (f (node-val t))
+                 (tree-map f (node-left t))
+                 (tree-map f (node-right t)))
+      (f t)))
+
+;; [X -> Y] [Tree X] -> unspecified
+(define (tree-for-each f t)
+  (if (node? t)
+      (begin (f (node-val t))
+             (tree-for-each f (node-left t))
+             (tree-for-each f (node-right t)))
+      (f t)))
+
+;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> [Tree R]
+(define (tree-map/n f ts)
+  (let recr ((ts ts))
+    (if (and (pair? ts)
+             (node? (car ts)))
+        (make-node (apply f (map node-val ts))
+                   (recr (map node-left ts))
+                   (recr (map node-right ts)))
+        (apply f ts))))
+
+;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> unspecified
+(define (tree-for-each/n f ts)
+  (let recr ((ts ts))
+    (if (and (pair? ts)
+             (node? (car ts)))
+        (begin (apply f (map node-val ts))
+               (recr (map node-left ts))
+               (recr (map node-right ts)))
+        (apply f ts))))
+
+;; Nat [Nat -> X] -> [Tree X]
+;; like build-list, but for complete binary trees
+(define (build-tree i f) ;; i = 2^j-1
+  (let rec ((i i) (o 0))
+    (if (= 1 i) 
+        (f o)
+        (let ((i/2 (half i)))
+          (make-node (f o)
+                     (rec i/2 (add1 o))
+                     (rec i/2 (+ 1 o i/2)))))))
+
+;; Consumes n = 2^i-1 and produces 2^(i-1)-1.
+;; Nat -> Nat
+(define (half n)
+  (bitwise-arithmetic-shift n -1))
+
+;; Nat X -> [Tree X]
+(define (tr:make-tree i x) ;; i = 2^j-1
+  (let recr ((i i))
+    (if (= 1 i) 
+        x
+        (let ((n (recr (half i))))
+          (make-node x n n)))))
+
+;; Nat [Tree X] Nat [X -> X] -> X [Tree X]
+(define (tree-ref/update mid t i f)
+  (cond ((zero? i)
+         (if (node? t) 
+             (values (node-val t)
+                     (make-node (f (node-val t))
+                                (node-left t)
+                                (node-right t)))
+             (values t (f t))))
+        ((<= i mid)
+         (let-values (((v* t*) (tree-ref/update (half (sub1 mid)) 
+                                                (node-left t) 
+                                                (sub1 i) 
+                                                f)))
+           (values v* (make-node (node-val t) t* (node-right t)))))
+        (else           
+         (let-values (((v* t*) (tree-ref/update (half (sub1 mid)) 
+                                                (node-right t) 
+                                                (sub1 (- i mid)) 
+                                                f)))
+           (values v* (make-node (node-val t) (node-left t) t*))))))
+
+;; Special-cased above to avoid logarathmic amount of cons'ing
+;; and any multi-values overhead.  Operates in constant space.
+;; [Tree X] Nat Nat -> X
+;; invariant: (= mid (half (sub1 (tree-count t))))
+(define (tree-ref/a t i mid) 
+  (cond ((zero? i) (tree-val t))
+        ((<= i mid) 
+         (tree-ref/a (node-left t) 
+                     (sub1 i) 
+                     (half (sub1 mid))))
+        (else 
+         (tree-ref/a (node-right t) 
+                     (sub1 (- i mid)) 
+                     (half (sub1 mid))))))
+
+;; Nat [Tree X] Nat -> X
+;; invariant: (= size (tree-count t))
+(define (tree-ref size t i)
+  (if (zero? i)
+      (tree-val t)
+      (tree-ref/a t i (half (sub1 size)))))
+
+;; Nat [Tree X] Nat [X -> X] -> [Tree X]
+(define (tree-update size t i f)
+  (let recr ((mid (half (sub1 size))) (t t) (i i))
+    (cond ((zero? i)
+           (if (node? t)
+               (make-node (f (node-val t))
+                          (node-left t)
+                          (node-right t))
+               (f t)))
+          ((<= i mid)
+           (make-node (node-val t) 
+                      (recr (half (sub1 mid))
+                            (node-left t) 
+                            (sub1 i)) 
+                      (node-right t)))
+          (else
+           (make-node (node-val t) 
+                      (node-left t) 
+                      (recr (half (sub1 mid))
+                            (node-right t) 
+                            (sub1 (- i mid))))))))
+
+;; ------------------------
+;; Random access lists
+
+;; [RaListof X]
+(define ra:null (quote ()))
+
+;; [Any -> Boolean]
+(define ra:pair? kons?)
+
+;; [Any -> Boolean]
+(define ra:null? null?)
+
+;; X [RaListof X] -> [RaListof X]  /\
+;; X Y -> [RaPair X Y]
+(define (ra:cons x ls)
+  (if (kons? ls)
+      (let ((s (kons-size ls)))
+        (if (and (kons? (kons-rest ls))
+                 (= (kons-size (kons-rest ls))
+                    s))
+            (make-kons (+ 1 s s) 
+                       (make-node x 
+                                  (kons-tree ls)
+                                  (kons-tree (kons-rest ls)))
+                       (kons-rest (kons-rest ls)))
+            (make-kons 1 x ls)))
+      (make-kons 1 x ls)))
+
+
+;; [RaPair X Y] -> X Y
+(define ra:car+cdr 
+  (lambda (p)
+    (assert (kons? p))
+    (if (node? (kons-tree p))
+        (let ((s* (half (kons-size p))))
+          (values (tree-val (kons-tree p))
+                  (make-kons s* 
+                             (node-left (kons-tree p))
+                             (make-kons s*
+                                        (node-right (kons-tree p))
+                                        (kons-rest p)))))
+        (values (kons-tree p) (kons-rest p)))))
+
+;; [RaPair X Y] -> X
+(define (ra:car p)
+  (call-with-values (lambda () (ra:car+cdr p))
+                    (lambda (car cdr) car)))
+
+;; [RaPair X Y] -> Y
+(define (ra:cdr p)
+  (call-with-values (lambda () (ra:car+cdr p))
+                    (lambda (car cdr) cdr)))
+
+;; [RaListof X] Nat [X -> X] -> X [RaListof X]
+(define (ra:list-ref/update ls i f)
+  ;(assert (< i (ra:length ls)))
+  (let recr ((xs ls) (j i))
+    (if (< j (kons-size xs))
+        (let-values (((v* t*) 
+                      (tree-ref/update (half (sub1 (kons-size xs))) 
+                                       (kons-tree xs) j f)))
+          (values v* (make-kons (kons-size xs) 
+                                t* 
+                                (kons-rest xs))))
+        (let-values (((v* r*) 
+                      (recr (kons-rest xs) 
+                            (- j (kons-size xs)))))
+          (values v* (make-kons (kons-size xs) 
+                                (kons-tree xs) 
+                                r*))))))
+
+;; [RaListof X] Nat [X -> X] -> [RaListof X]
+(define (ra:list-update ls i f)
+  ;(assert (< i (ra:length ls)))
+  (let recr ((xs ls) (j i))
+    (let ((s (kons-size xs)))
+      (if (< j s) 
+          (make-kons s (tree-update s (kons-tree xs) j f) (kons-rest xs))
+          (make-kons s (kons-tree xs) (recr (kons-rest xs) (- j s)))))))
+
+;; [RaListof X] Nat X -> (values X [RaListof X])
+(define (ra:list-ref/set ls i v)
+  (ra:list-ref/update ls i (lambda (_) v)))
+
+;; X ... -> [RaListof X]
+(define (ra:list . xs)
+  (fold-right ra:cons ra:null xs))
+
+;; Nat X -> [RaListof X]
+(define ra:make-list
+  (case-lambda
+   ((k) (ra:make-list k 0))
+   ((k obj)
+    (let loop ((n k) (a ra:null))
+      (cond ((zero? n) a)
+            (else 
+             (let ((t (largest-skew-binary n)))
+               (loop (- n t)
+                     (make-kons t (tr:make-tree t obj) a)))))))))
+
+;; A Skew is a Nat 2^k-1 with k > 0.
+
+;; Skew -> Skew
+(define (skew-succ t) (add1 (bitwise-arithmetic-shift t 1)))
+
+;; Computes the largest skew binary term t <= n.
+;; Nat -> Skew
+(define (largest-skew-binary n)
+  (if (= 1 n) 
+      1
+      (let* ((t (largest-skew-binary (half n)))
+             (s (skew-succ t)))
+        (if (> s n) t s))))  
+
+;; [Any -> Boolean]
+;; Is x a PROPER list?
+(define (ra:list? x)
+  (or (ra:null? x)
+      (and (kons? x)
+           (ra:list? (kons-rest x)))))
+
+(define ra:caar (lambda (ls) (ra:car (ra:car ls))))
+(define ra:cadr (lambda (ls) (ra:car (ra:cdr ls))))
+(define ra:cddr (lambda (ls) (ra:cdr (ra:cdr ls))))
+(define ra:cdar (lambda (ls) (ra:cdr (ra:car ls))))
+
+(define ra:caaar (lambda (ls) (ra:car (ra:car (ra:car ls)))))
+(define ra:caadr (lambda (ls) (ra:car (ra:car (ra:cdr ls)))))
+(define ra:caddr (lambda (ls) (ra:car (ra:cdr (ra:cdr ls)))))
+(define ra:cadar (lambda (ls) (ra:car (ra:cdr (ra:car ls)))))
+(define ra:cdaar (lambda (ls) (ra:cdr (ra:car (ra:car ls)))))
+(define ra:cdadr (lambda (ls) (ra:cdr (ra:car (ra:cdr ls)))))
+(define ra:cdddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr ls)))))
+(define ra:cddar (lambda (ls) (ra:cdr (ra:cdr (ra:car ls)))))
+
+(define ra:caaaar (lambda (ls) (ra:car (ra:car (ra:car (ra:car ls))))))
+(define ra:caaadr (lambda (ls) (ra:car (ra:car (ra:car (ra:cdr ls))))))
+(define ra:caaddr (lambda (ls) (ra:car (ra:car (ra:cdr (ra:cdr ls))))))
+(define ra:caadar (lambda (ls) (ra:car (ra:car (ra:cdr (ra:car ls))))))
+(define ra:cadaar (lambda (ls) (ra:car (ra:cdr (ra:car (ra:car ls))))))
+(define ra:cadadr (lambda (ls) (ra:car (ra:cdr (ra:car (ra:cdr ls))))))
+(define ra:cadddr (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:cdr ls))))))
+(define ra:caddar (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:car ls))))))
+(define ra:cdaaar (lambda (ls) (ra:cdr (ra:car (ra:car (ra:car ls))))))
+(define ra:cdaadr (lambda (ls) (ra:cdr (ra:car (ra:car (ra:cdr ls))))))
+(define ra:cdaddr (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:cdr ls))))))
+(define ra:cdadar (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:car ls))))))
+(define ra:cddaar (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:car ls))))))
+(define ra:cddadr (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:cdr ls))))))
+(define ra:cddddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:cdr ls))))))
+(define ra:cdddar (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:car ls))))))
+
+;; [RaList X] -> Nat
+(define (ra:length ls)
+  (assert (ra:list? ls))
+  (let recr ((ls ls))
+    (if (kons? ls)
+        (+ (kons-size ls) (recr (kons-rest ls)))
+        0)))
+
+(define (make-foldl empty? first rest)
+  (letrec ((f (lambda (cons empty ls)
+                (if (empty? ls) 
+                    empty
+                    (f cons
+                       (cons (first ls) empty) 
+                       (rest ls))))))
+    f))
+
+(define (make-foldr empty? first rest)
+  (letrec ((f (lambda (cons empty ls)
+                (if (empty? ls) 
+                    empty
+                    (cons (first ls)
+                          (f cons empty (rest ls)))))))
+    f))
+
+;; [X Y -> Y] Y [RaListof X] -> Y
+(define ra:foldl/1 (make-foldl ra:null? ra:car ra:cdr))
+(define ra:foldr/1 (make-foldr ra:null? ra:car ra:cdr))
+
+;; [RaListof X] ... -> [RaListof X]
+(define (ra:append . lss)
+  (cond ((null? lss) ra:null)
+        (else (let recr ((lss lss))
+                (cond ((null? (cdr lss)) (car lss))
+                      (else (ra:foldr/1 ra:cons
+                                        (recr (cdr lss))
+                                        (car lss))))))))
+
+;; [RaListof X] -> [RaListof X]
+(define (ra:reverse ls)
+  (ra:foldl/1 ra:cons ra:null ls))
+
+;; [RaListof X] Nat -> [RaListof X]
+(define (ra:list-tail ls i)
+  (let loop ((xs ls) (j i))
+    (cond ((zero? j) xs)
+          (else (loop (ra:cdr xs) (sub1 j))))))
+
+;; [RaListof X] Nat -> X
+;; Special-cased above to avoid logarathmic amount of cons'ing
+;; and any multi-values overhead.  Operates in constant space.
+(define (ra:list-ref ls i)
+  ;(assert (< i (ra:length ls)))
+  (let loop ((xs ls) (j i))
+    (if (< j (kons-size xs))
+        (tree-ref (kons-size xs) (kons-tree xs) j)
+        (loop (kons-rest xs) (- j (kons-size xs))))))
+
+;; [RaListof X] Nat X -> [RaListof X]
+(define (ra:list-set ls i v)
+  (let-values (((_ l*) (ra:list-ref/set ls i v))) l*))
+
+;; [X ... -> y] [RaListof X] ... -> [RaListof Y]
+;; Takes advantage of the fact that map produces a list of equal size.
+(define ra:map
+  (case-lambda 
+    ((f ls)
+     (let recr ((ls ls))
+       (if (kons? ls)
+           (make-kons (kons-size ls) 
+                      (tree-map f (kons-tree ls)) 
+                      (recr (kons-rest ls)))
+           ra:null)))
+    ((f . lss)
+     ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss)
+     (let recr ((lss lss))
+       (cond ((ra:null? (car lss)) ra:null)
+             (else
+              ;; IMPROVE ME: make one pass over lss.
+              (make-kons (kons-size (car lss))
+                         (tree-map/n f (map kons-tree lss))
+                         (recr (map kons-rest lss)))))))))
+
+
+;; [X ... -> Y] [RaListof X] ... -> unspecified
+(define ra:for-each
+  (case-lambda 
+    ((f ls)
+     (when (kons? ls)
+       (tree-for-each f (kons-tree ls))
+       (ra:for-each f (kons-rest ls))))
+    ((f . lss)
+     ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss)
+     (let recr ((lss lss))
+       (when (ra:pair? (car lss))
+         (tree-map/n f (map kons-tree lss))
+         (recr (map kons-rest lss)))))))
+
+;; [RaListof X] -> [Listof X]
+(define (ra:random-access-list->linear-access-list x)
+  (ra:foldr/1 cons '() x))
+
+;; [Listof X] -> [RaListof X]
+(define (ra:linear-access-list->random-access-list x)
+  (fold-right ra:cons '() x))
+
+;; This code based on code written by Abdulaziz Ghuloum
+;; http://ikarus-scheme.org/pipermail/ikarus-users/2009-September/000595.html
+(define get-cached
+  (let ((h (make-hash-table eq?)))
+    (lambda (x)
+      (define (f x)
+        (cond
+         ((pair? x) (ra:cons (f (car x)) (f (cdr x))))
+         ((vector? x) (vector-map f x))
+         (else x)))
+      (cond
+       ((not (or (pair? x) (vector? x))) x)
+       ((hash-table-ref/default h x #f))
+       (else
+        (let ((v (f x)))
+          (hash-table-set! h x v)
+          v))))))
+
+(define-syntax ra:quote
+  (syntax-rules ()
+    ((ra:quote datum) (get-cached 'datum)))) 

lib/srfi/101.sld

@@ -0,0 +1,59 @@
+
+(define-library (srfi 101)
+  (import (scheme base)
+          (scheme case-lambda)
+          (srfi 1)
+          (srfi 125)
+          (rename (srfi 151)
+                  (arithmetic-shift bitwise-arithmetic-shift)))
+  (export (rename ra:quote quote)
+          (rename ra:pair? pair?)
+          (rename ra:cons cons)
+          (rename ra:car car)
+          (rename ra:cdr cdr)
+          (rename ra:caar caar)
+          (rename ra:cadr cadr)
+          (rename ra:cddr cddr)
+          (rename ra:cdar cdar)
+          (rename ra:caaar caaar)
+          (rename ra:caadr caadr)
+          (rename ra:caddr caddr)
+          (rename ra:cadar cadar)
+          (rename ra:cdaar cdaar)
+          (rename ra:cdadr cdadr)
+          (rename ra:cdddr cdddr)
+          (rename ra:cddar cddar)
+          (rename ra:caaaar caaaar)
+          (rename ra:caaadr caaadr)
+          (rename ra:caaddr caaddr)
+          (rename ra:caadar caadar)
+          (rename ra:cadaar cadaar)
+          (rename ra:cadadr cadadr)
+          (rename ra:cadddr cadddr)
+          (rename ra:caddar caddar)
+          (rename ra:cdaaar cdaaar)
+          (rename ra:cdaadr cdaadr)
+          (rename ra:cdaddr cdaddr)
+          (rename ra:cdadar cdadar)
+          (rename ra:cddaar cddaar)
+          (rename ra:cddadr cddadr)
+          (rename ra:cddddr cddddr)
+          (rename ra:cdddar cdddar)
+          (rename ra:null? null?)
+          (rename ra:list? list?)
+          (rename ra:list list)
+          (rename ra:make-list make-list)
+          (rename ra:length length)
+          (rename ra:append append)
+          (rename ra:reverse reverse)
+          (rename ra:list-tail list-tail)
+          (rename ra:list-ref list-ref)
+          (rename ra:list-set list-set)
+          (rename ra:list-ref/update list-ref/update)
+          (rename ra:map map)
+          (rename ra:for-each for-each)
+          (rename ra:random-access-list->linear-access-list
+                  random-access-list->linear-access-list)
+          (rename ra:linear-access-list->random-access-list
+                  linear-access-list->random-access-list))
+  (include "101.scm"))

lib/srfi/101/test.sld

@@ -0,0 +1,143 @@
+
+;; Adapted from the reference implementation test suite for R7RS.
+
+(define-library (srfi 101 test)
+  (import (except (scheme base)
+                  quote pair? cons car cdr 
+                  caar cadr cddr cdar
+                  null? list? list make-list length 
+                  append reverse list-tail
+                  list-ref map for-each)
+          (prefix (scheme base) r7:)
+          (srfi 101)
+          (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+
+      (test-begin "srfi-101: random access lists")
+
+      (test-assert (let ((f (lambda () '(x))))
+                     (eq? (f) (f))))
+
+      (test '(1 2 3) (list 1 2 3))
+
+      ;; pair?
+      (test-assert (pair? (cons 'a 'b)))
+      (test-assert (pair? (list 'a 'b 'c)))
+      (test-not (pair? '()))
+      (test-not (pair? '#(a b)))
+
+      ;; cons
+      (test (cons 'a '()) (list 'a))
+      (test (cons (list 'a) (list 'b 'c 'd))
+          (list (list 'a) 'b 'c 'd))
+      (test (cons "a" (list 'b 'c))
+          (list "a" 'b 'c))
+      (test (cons 'a 3)
+          (cons 'a 3))
+      (test (cons (list 'a 'b) 'c)
+          (cons (list 'a 'b) 'c))
+
+      ;; car
+      (test 'a
+          (car (list 'a 'b 'c)))
+      (test (list 'a)
+          (car (list (list 'a) 'b 'c 'd)))
+      (test 1 (car (cons 1 1)))
+      (test-error (car '()))
+
+      ;; cdr
+      (test (list 'b 'c 'd)
+          (cdr (list (list 'a) 'b 'c 'd)))
+      (test 2
+          (cdr (cons 1 2)))
+      (test-error (cdr '()))
+
+      ;; null?
+      (test-assert (eq? null? r7:null?))
+      (test-assert (null? '()))
+      (test-not (null? (cons 1 2)))
+      (test-not (null? 4))
+
+      ;; list?
+      (test-assert (list? (list 'a 'b 'c)))
+      (test-assert (list? '()))
+      (test-not (list? (cons 'a 'b)))
+
+      ;; list
+      (test (list 'a 7 'c)
+          (list 'a (+ 3 4) 'c))
+      (test '() (list))
+
+      ;; make-list
+      (test 5 (length (make-list 5)))
+      (test (list 0 0 0 0 0)
+          (make-list 5 0))
+
+      ;; length
+      (test 3 (length (list 'a 'b 'c)))
+      (test 3 (length (list 'a (list 'b) (list 'c))))
+      (test 0 (length '()))
+
+      ;; append
+      (test (list 'x 'y) (append (list 'x) (list 'y)))
+      (test (list 'a 'b 'c 'd) (append (list 'a) (list 'b 'c 'd)))
+      (test (list 'a (list 'b) (list 'c)) 
+          (append (list 'a (list 'b)) (list (list 'c))))
+      (test (cons 'a (cons 'b (cons 'c 'd))) 
+          (append (list 'a 'b) (cons 'c 'd)))
+      (test 'a (append '() 'a))
+
+      ;; reverse
+      (test (list 'c 'b 'a)
+          (reverse (list 'a 'b 'c)))
+      (test (list (list 'e (list 'f)) 'd (list 'b 'c) 'a)
+          (reverse (list 'a (list 'b 'c) 'd (list 'e (list 'f)))))
+
+      ;; list-tail
+      (test (list 'c 'd)
+          (list-tail (list 'a 'b 'c 'd) 2))
+
+      ;; list-ref
+      (test 'c (list-ref (list 'a 'b 'c 'd) 2))
+
+      ;; list-set
+      (test (list 'a 'b 'x 'd)
+          (list-set (list 'a 'b 'c 'd) 2 'x))
+
+      ;; list-ref/update
+      (let-values (((a b) 
+                    (list-ref/update (list 7 8 9 10) 2 -)))
+        (test 9 a)
+        (test (list 7 8 -9 10) (values b)))
+
+      ;; map
+      (test (list 'b 'e 'h)
+          (map cadr (list (list 'a 'b) (list 'd 'e) (list 'g 'h))))
+      (test (list 1 4 27 256 3125)
+          (map (lambda (n) (expt n n))
+                 (list 1 2 3 4 5)))
+      (test (list 5 7 9)
+          (map + (list 1 2 3) (list 4 5 6)))
+
+      ;; for-each
+      (test '#(0 1 4 9 16)
+          (let ((v (make-vector 5)))
+              (for-each (lambda (i)
+                          (vector-set! v i (* i i)))
+                        (list 0 1 2 3 4))
+              v))
+
+      ;; random-access-list->linear-access-list
+      ;; linear-access-list->random-access-list
+      (test '() (random-access-list->linear-access-list '()))
+      (test '() (linear-access-list->random-access-list '()))
+
+      (test (r7:list 1 2 3)
+          (random-access-list->linear-access-list (list 1 2 3)))
+
+      (test (list 1 2 3)
+          (linear-access-list->random-access-list (r7:list 1 2 3)))
+
+      (test-end))))

tests/lib-tests.scm

@@ -13,9 +13,11 @@
         (rename (srfi 69 test) (run-tests run-srfi-69-tests))
         (rename (srfi 95 test) (run-tests run-srfi-95-tests))
         (rename (srfi 99 test) (run-tests run-srfi-99-tests))
+        (rename (srfi 101 test) (run-tests run-srfi-101-tests))
         (rename (srfi 116 test) (run-tests run-srfi-116-tests))
         (rename (srfi 117 test) (run-tests run-srfi-117-tests))
         (rename (srfi 121 test) (run-tests run-srfi-121-tests))
+        (rename (srfi 125 test) (run-tests run-srfi-125-tests))
         (rename (srfi 127 test) (run-tests run-srfi-127-tests))
         (rename (srfi 128 test) (run-tests run-srfi-128-tests))
         (rename (srfi 129 test) (run-tests run-srfi-129-tests))
@@ -68,9 +70,11 @@
 (run-srfi-69-tests)
 (run-srfi-95-tests)
 (run-srfi-99-tests)
+(run-srfi-101-tests)
 (run-srfi-116-tests)
 (run-srfi-117-tests)
 (run-srfi-121-tests)
+(run-srfi-125-tests)
 (run-srfi-127-tests)
 (run-srfi-128-tests)
 (run-srfi-129-tests)