1 files changed, 144 insertions, 0 deletions
diff --git a/lib/scheme/base/60-list.csc b/lib/scheme/base/60-list.csc
new file mode 100644
index 0000000..cbfc12a
--- /dev/null
+++ b/lib/scheme/base/60-list.csc
@@ -0,0 +1,144 @@
+(export
+  append
+  caar
+  cadr
+  car
+  cdar
+  cddr
+  cdr
+  cons
+  length
+  list
+  list-copy
+  list-ref
+  list-set!
+  list-tail
+  list?
+  make-list
+  null?
+  pair?
+  reverse
+  set-car!
+  set-cdr!)
+(import (only (csc builtins)
+          call-builtin))
+(begin
+
+
+  (define-record-type <pair>
+    (cons x y)
+    pair?
+    (x car set-car!)
+    (y cdr set-cdr!))
+
+
+  (define (caar pair)
+    (car (car pair)))
+
+
+  (define (cadr pair)
+    (car (cdr pair)))
+
+
+  (define (cdar pair)
+    (cdr (car pair)))
+
+
+  (define (cddr pair)
+    (cdr (cdr pair)))
+
+
+  (define (null? obj)
+    (call-builtin eq? obj '()))
+
+
+  (define (list? obj)
+    (cond
+      ((null? obj) #t)
+      ((not (pair? obj)) #f)
+      (else
+        (let loop ((tortoise obj)
+                   (hare (cdr obj)))
+          (cond
+            ((null? hare) #t)
+            ((not (pair? hare)) #f)
+            ((null? (cdr hare)) #t)
+            ((not (pair? (cdr hare))) #f)
+            ((eq? tortoise hare) #f)  ; cycle detected
+            (else
+              (loop (cdr tortoise)
+                    (cddr hare))))))))
+
+
+  (define make-list
+    (case-lambda
+      ((k)
+        (make-list k #f))
+      ((k fill)
+        (let loop ((k k)
+                   (acc '()))
+          (if (zero? k)
+            acc
+            (loop (- k 1) (cons fill acc)))))))
+
+
+  (define (list . args)
+    args)
+
+
+  (define (length l)
+    (let loop ((l l)
+               (n 0))
+      (if (null? l)
+        n
+        (loop (cdr l) (+ 1 n)))))
+
+
+  (define (append2 l1 l2)
+    (let loop ((l1 l1))
+      (if (null? l1)
+        l2
+        (cons (car l1) (loop (cdr l1))))))
+
+
+  (define (append . ls)
+    (let loop ((ls ls))
+      (cond
+        ((null? ls) '())
+        ((null? (cdr ls))
+          (car ls))
+        (else
+          (append2 (car ls)
+                   (loop (cdr ls)))))))
+
+
+  (define (reverse l)
+    (let loop ((l l)
+               (acc '()))
+      (if (null? l)
+        acc
+        (loop (cdr l) (cons (car l) acc)))))
+
+
+  (define (list-tail l k)
+    (if (zero? k)
+      l
+      (list-tail (cdr l) (- k 1))))
+
+
+  (define (list-ref l k)
+    (car (list-tail l k)))
+
+
+  (define (list-set! l k obj)
+    (let loop ((l l)
+               (k k))
+      (if (zero? k)
+        (set-car! l obj)
+        (loop (cdr l) (- k 1)))))
+
+
+  (define (list-copy obj)
+    (if (pair? l)
+      (cons (car l) (list-copy (cdr l)))
+      l)))