diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 1f7fccfa..f8c921e7 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -49,6 +49,8 @@ int pic_length(pic_state *, pic_value); pic_value pic_reverse(pic_state *, pic_value); 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_assq(pic_state *, pic_value key, pic_value assoc); pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc); 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 3b84c974..482818af 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -39,13 +39,6 @@ (import (scheme base) (picrin dictionary)) - (define (memq obj list) - (if (null? list) - #f - (if (eq? obj (car list)) - list - (memq obj (cdr list))))) - (define (list->vector list) (define vector (make-vector (length list))) (define (go list i) @@ -830,13 +823,6 @@ ;;; 6.4 Pairs and lists -(define (memq obj list) - (if (null? list) - #f - (if (eq? obj (car list)) - list - (memq obj (cdr list))))) - (define (memv obj list) (if (null? list) #f @@ -844,13 +830,6 @@ list (memq obj (cdr list))))) -(define (assq obj list) - (if (null? list) - #f - (if (eq? obj (caar list)) - (car list) - (assq obj (cdr list))))) - (define (assv obj list) (if (null? list) #f @@ -874,8 +853,8 @@ (car list) (assoc obj (cdr list) compare))))) -(export memq memv member - assq assv assoc) +(export memv member + assv assoc) ;;; 6.5. Symbols diff --git a/src/pair.c b/src/pair.c index 499b7bb5..068fab47 100644 --- a/src/pair.c +++ b/src/pair.c @@ -261,6 +261,21 @@ pic_append(pic_state *pic, pic_value xs, pic_value ys) return ys; } +pic_value +pic_memq(pic_state *pic, pic_value key, pic_value list) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (pic_eq_p(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) { @@ -594,6 +609,26 @@ pic_pair_list_copy(pic_state *pic) return pic_list_copy(pic, obj); } +static pic_value +pic_pair_memq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_memq(pic, key, list); +} + +static pic_value +pic_pair_assq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_assq(pic, key, list); +} + void pic_init_pair(pic_state *pic) { @@ -618,4 +653,6 @@ pic_init_pair(pic_state *pic) pic_defun(pic, "list-ref", pic_pair_list_ref); pic_defun(pic, "list-set!", pic_pair_list_set); pic_defun(pic, "list-copy", pic_pair_list_copy); + pic_defun(pic, "memq", pic_pair_memq); + pic_defun(pic, "assq", pic_pair_assq); }