From 3f6ec5f8786c7d267fefbf5bb2b3b8e9a0756360 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 13:19:25 +0900
Subject: [PATCH] implement assoc and member in c

---
 include/picrin/pair.h |  3 ++-
 piclib/prelude.scm    | 20 ----------------
 src/lib.c             |  2 +-
 src/pair.c            | 55 ++++++++++++++++++++++++++++++++++++++++---
 4 files changed, 55 insertions(+), 25 deletions(-)

diff --git a/include/picrin/pair.h b/include/picrin/pair.h
index c7319e25..49de01cc 100644
--- a/include/picrin/pair.h
+++ b/include/picrin/pair.h
@@ -51,10 +51,11 @@ pic_value pic_append(pic_state *, pic_value, pic_value);
 
 pic_value pic_memq(pic_state *, pic_value key, pic_value list);
 pic_value pic_memv(pic_state *, pic_value key, pic_value list);
+pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */);
 
 pic_value pic_assq(pic_state *, pic_value key, pic_value assoc);
 pic_value pic_assv(pic_state *, pic_value key, pic_value assoc);
-pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc);
+pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */);
 
 pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc);
 
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index af357cdb..6145b9dd 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -589,26 +589,6 @@
       s
       (fold f (f (car xs) s) (cdr xs))))
 
-;;; 6.4 Pairs and lists
-
-(define (member obj list . opts)
-  (let ((compare (if (null? opts) equal? (car opts))))
-    (if (null? list)
-	#f
-	(if (compare obj (car list))
-	    list
-	    (member obj (cdr list) compare)))))
-
-(define (assoc obj list . opts)
-  (let ((compare (if (null? opts) equal? (car opts))))
-    (if (null? list)
-	#f
-	(if (compare obj (caar list))
-	    (car list)
-	    (assoc obj (cdr list) compare)))))
-
-(export member assoc)
-
 ;;; 6.6 Characters
 
 (define-macro (define-char-transitive-predicate name op)
diff --git a/src/lib.c b/src/lib.c
index 5ac5336a..7a197c87 100644
--- a/src/lib.c
+++ b/src/lib.c
@@ -54,7 +54,7 @@ pic_find_library(pic_state *pic, pic_value spec)
 {
   pic_value v;
 
-  v = pic_assoc(pic, spec, pic->lib_tbl);
+  v = pic_assoc(pic, spec, pic->lib_tbl, NULL);
   if (pic_false_p(v)) {
     return NULL;
   }
diff --git a/src/pair.c b/src/pair.c
index 2c80f363..f2960adb 100644
--- a/src/pair.c
+++ b/src/pair.c
@@ -291,6 +291,26 @@ pic_memv(pic_state *pic, pic_value key, pic_value list)
   goto enter;
 }
 
+pic_value
+pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar)
+{
+ enter:
+
+  if (pic_nil_p(list))
+    return pic_false_value();
+
+  if (compar == NULL) {
+    if (pic_equal_p(pic, key, pic_car(pic, list)))
+      return list;
+  } else {
+    if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list))))
+      return list;
+  }
+
+  list = pic_cdr(pic, list);
+  goto enter;
+}
+
 pic_value
 pic_assq(pic_state *pic, pic_value key, pic_value assoc)
 {
@@ -328,7 +348,7 @@ pic_assv(pic_state *pic, pic_value key, pic_value assoc)
 }
 
 pic_value
-pic_assoc(pic_state *pic, pic_value key, pic_value assoc)
+pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar)
 {
   pic_value cell;
 
@@ -338,8 +358,13 @@ pic_assoc(pic_state *pic, pic_value key, pic_value assoc)
     return pic_false_value();
 
   cell = pic_car(pic, assoc);
-  if (pic_equal_p(pic, key, pic_car(pic, cell)))
-    return cell;
+  if (compar == NULL) {
+    if (pic_equal_p(pic, key, pic_car(pic, cell)))
+      return cell;
+  } else {
+    if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell))))
+      return cell;
+  }
 
   assoc = pic_cdr(pic, assoc);
   goto enter;
@@ -662,6 +687,17 @@ pic_pair_memv(pic_state *pic)
   return pic_memv(pic, key, list);
 }
 
+static pic_value
+pic_pair_member(pic_state *pic)
+{
+  struct pic_proc *proc = NULL;
+  pic_value key, list;
+
+  pic_get_args(pic, "oo|l", &key, &list, &proc);
+
+  return pic_member(pic, key, list, proc);
+}
+
 static pic_value
 pic_pair_assq(pic_state *pic)
 {
@@ -682,6 +718,17 @@ pic_pair_assv(pic_state *pic)
   return pic_assv(pic, key, list);
 }
 
+static pic_value
+pic_pair_assoc(pic_state *pic)
+{
+  struct pic_proc *proc = NULL;
+  pic_value key, list;
+
+  pic_get_args(pic, "oo|l", &key, &list, &proc);
+
+  return pic_assoc(pic, key, list, proc);
+}
+
 void
 pic_init_pair(pic_state *pic)
 {
@@ -708,6 +755,8 @@ pic_init_pair(pic_state *pic)
   pic_defun(pic, "list-copy", pic_pair_list_copy);
   pic_defun(pic, "memq", pic_pair_memq);
   pic_defun(pic, "memv", pic_pair_memv);
+  pic_defun(pic, "member", pic_pair_member);
   pic_defun(pic, "assq", pic_pair_assq);
   pic_defun(pic, "assv", pic_pair_assv);
+  pic_defun(pic, "assoc", pic_pair_assoc);
 }