~ chicken-r7rs (master) fab389daa7aa734a8004a10c9dd399ed1887d79e

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

    mem*, ass*, list-copy; this completes 6.4: pairs and lists

diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 3ac77e0..d1062cc 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -8,7 +8,9 @@
   append
   #|
   apply
+  |#
   assoc assq assv
+  #|
   begin
   binary-port?
   |#
@@ -106,11 +108,7 @@
   #|
   library                    ; for "cond-expand"
   |#
-  list
-  #|
-  list-copy
-  |#
-  list-ref list-set! list-tail list?
+  list list-copy list-ref list-set! list-tail list?
   #|
   make-bytevector
   |#
@@ -121,7 +119,9 @@
   make-vector
   map
   max min
+  |#
   member memq memv
+  #|
   modulo remainder
   negative? positive?
   newline
diff --git a/scheme.base.scm b/scheme.base.scm
index e6778a7..393b0d6 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -1,6 +1,6 @@
 (module scheme.base ()
 
-(import (except scheme syntax-rules cond-expand))
+(import (except scheme syntax-rules cond-expand member))
 (import (except chicken with-exception-handler raise))
 
 (include "scheme.base-interface.scm")
@@ -165,6 +165,61 @@
     (when (null? l)
       (error 'list-set! "out of range"))))
 
+(: member (forall (a b) (a (list-of b) #!optional (procedure (b a) *) ; sic
+                         -> (or boolean (list-of b)))))
+
+;; XXX These aren't exported to the types file!?
+(define-specialization (member (x (or symbol procedure immediate)) (lst list))
+  (##core#inline "C_u_i_memq" x lst))
+(define-specialization (member x (lst (list-of (or symbol procedure immediate))))
+  (##core#inline "C_u_i_memq" x lst))
+(define-specialization (member x lst)
+  (##core#inline "C_i_member" x lst))
+
+(define member
+  (case-lambda
+   ((x lst) (##core#inline "C_i_member" x lst))
+   ((x lst eq?)
+    (let lp ((lst lst))
+      (cond ((null? lst) #f)
+            ((eq? (car lst) x) lst)
+            (else (lp (cdr lst))))))))
+
+
+(: assoc (forall (a b c) (a (list-of (pair b c)) #!optional (procedure (b a) *) ; sic
+                            -> (or boolean (list-of (pair b c))))))
+
+;; XXX These aren't exported to the types file!?
+(define-specialization (assoc (x (or symbol procedure immediate)) (lst (list-of pair)))
+  (##core#inline "C_u_i_assq" x lst))
+(define-specialization (assoc x (lst (list-of (pair (or symbol procedure immediate) *))))
+  (##core#inline "C_u_i_assq" x lst))
+(define-specialization (assoc x lst)
+  (##core#inline "C_i_assoc" x lst))
+
+(define assoc
+  (case-lambda
+   ((x lst) (##core#inline "C_i_assoc" x lst))
+   ((x lst eq?)
+    (let lp ((lst lst))
+      (cond ((null? lst) #f)
+            ((not (pair? (car lst)))
+             (error 'assoc "unexpected non-pair in list" (car lst)))
+            ((eq? (caar lst) x) (car lst))
+            (else (lp (cdr lst))))))))
+
+
+(: list-copy (forall (a) ((list-of a) -> (list-of a))))
+
+;; TODO: Test if this is the quickest way to do this, or whether we
+;; should just cons recursively like our SRFI-1 implementation does.
+(define (list-copy lst)
+  (let lp ((res '())
+           (lst lst))
+    (if (null? lst)
+        (##sys#fast-reverse res)
+        (lp (cons (car lst) res) (cdr lst)))))
+
 ;;;
 ;;; 6.11. Exceptions
 ;;;
diff --git a/tests/run.scm b/tests/run.scm
index 08164b8..6ad6d63 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -197,7 +197,38 @@
       (test '(two three) (cdr ls)))
     ;; Should be an error?
     #;(list-set! '(0 1 2) 1 "oops")
-    ))
+    (test-error (list-set! (list 1 2 3) 3 'foo)))
+
+  (test-group "mem*"
+    (test '(a b c) (memq 'a '(a b c)))
+    (test '(b c) (memq 'b '(a b c)))
+    (test #f (memq 'a '(b c d)))
+    (test #f (memq (list 'a) '(b (a) c)))
+    (test '((a) c) (member (list 'a) '(b (a) c)))
+    (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))
+    (test '(101 102) (memq 101 '(100 101 102))) ; unspecified in R7RS
+    (test '(101 102) (memv 101 '(100 101 102))))
+
+  (test-group "ass*"
+    (define e '((a 1) (b 2) (c 3)))
+    (test '(a 1) (assq 'a e))
+    (test '(b 2) (assq 'b e))
+    (test #f (assq 'd e))
+    (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+    (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+    (test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))
+    (test '(5 7) (assq 5 '((2 3) (5 7) (11 13)))) ; unspecified in R7RS
+    (test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+    (test-error (assq 5 '(5 6 7)))
+    (test-error (assv 5 '(5 6 7)))
+    (test-error (assoc 5 '(5 6 7))))
+
+  (test-group "list-copy"
+   (define a '(1 8 2 8)) ; a may be immutable
+   (define b (list-copy a))
+   (set-car! b 3)        ; b is mutable
+   (test '((3 8 2 8)) (list b))
+   (test '((1 8 2 8)) (list a))))
 
 (define-syntax catch
   (syntax-rules ()