diff --git a/include/cyclone/runtime.h b/include/cyclone/runtime.h index 52065204..781815bf 100644 --- a/include/cyclone/runtime.h +++ b/include/cyclone/runtime.h @@ -347,6 +347,10 @@ extern const object primitive_cell; extern const object primitive_eq_127; extern const object primitive_eqv_127; extern const object primitive_equal_127; +extern const object primitive_assq; +extern const object primitive_assv; +extern const object primitive_memq; +extern const object primitive_memv; extern const object primitive_length; extern const object primitive_vector_91length; extern const object primitive_bytevector_91length; diff --git a/runtime.c b/runtime.c index 99a5ef1a..bbd51586 100644 --- a/runtime.c +++ b/runtime.c @@ -3410,6 +3410,30 @@ void _apply(void *data, object cont, object args) dispatch(data, obj_obj2int(argc), (function_type)dispatch_apply_va, cont, cont, args); } +void _assq(void *data, object cont, object args) +{ + Cyc_check_num_args(data, "assq ", 2, args); + return_closcall1(data, cont, assq(data, car(args), cadr(args))); +} + +void _assv(void *data, object cont, object args) +{ + Cyc_check_num_args(data, "assv ", 2, args); + return_closcall1(data, cont, assq(data, car(args), cadr(args))); +} + +void _memq(void *data, object cont, object args) +{ + Cyc_check_num_args(data, "memq", 2, args); + return_closcall1(data, cont, memqp(data, car(args), cadr(args))); +} + +void _memv(void *data, object cont, object args) +{ + Cyc_check_num_args(data, "memv", 2, args); + return_closcall1(data, cont, memqp(data, car(args), cadr(args))); +} + void _char_91_125integer(void *data, object cont, object args) { Cyc_check_num_args(data, "char->integer", 1, args); @@ -4316,6 +4340,10 @@ static primitive_type eqv_127_primitive = { {0}, primitive_tag, "eqv?", &_eqv_127 }; static primitive_type equal_127_primitive = { {0}, primitive_tag, "equal?", &_equal_127 }; +static primitive_type assq_primitive = { {0}, primitive_tag, "assq", &_assq }; +static primitive_type assv_primitive = { {0}, primitive_tag, "assv", &_assv }; +static primitive_type memq_primitive = { {0}, primitive_tag, "memq", &_memq }; +static primitive_type memv_primitive = { {0}, primitive_tag, "memv", &_memv }; static primitive_type length_primitive = { {0}, primitive_tag, "length", &_length }; static primitive_type bytevector_91length_primitive = @@ -4539,6 +4567,10 @@ const object primitive_cell = &cell_primitive; const object primitive_eq_127 = &eq_127_primitive; const object primitive_eqv_127 = &eqv_127_primitive; const object primitive_equal_127 = &equal_127_primitive; +const object primitive_assq = &assq_primitive; +const object primitive_assv = &assv_primitive; +const object primitive_memq = &memq_primitive; +const object primitive_memv = &memv_primitive; const object primitive_length = &length_primitive; const object primitive_bytevector_91length = &bytevector_91length_primitive; const object primitive_vector_91length = &vector_91length_primitive; diff --git a/scheme/base.sld b/scheme/base.sld index ccdb9057..e7769a1b 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -10,11 +10,11 @@ (import (scheme cyclone common)) (export member - memv - memq + ;memv + ;memq assoc - assv - assq + ;assv + ;assq cons-source syntax-rules letrec* @@ -542,8 +542,8 @@ (if (pair? compare) (member-helper obj lst (car compare)) (member-helper obj lst equal?))) - (define (memq obj lst) (member-helper obj lst eq?)) - (define (memv obj lst) (member-helper obj lst eqv?)) + ;(define (memq obj lst) (member-helper obj lst eq?)) + ;(define (memv obj lst) (member-helper obj lst eqv?)) (define (assoc-helper obj lst cmp?) (cond @@ -557,8 +557,8 @@ (if (pair? compare) (assoc-helper obj alist (car compare)) (assoc-helper obj alist equal?))) - (define (assq obj alist) (assoc-helper obj alist eq?)) - (define (assv obj alist) (assoc-helper obj alist eqv?)) + ;(define (assq obj alist) (assoc-helper obj alist eq?)) + ;(define (assv obj alist) (assoc-helper obj alist eqv?)) (define (foldl func accum lst) (if (null? lst) diff --git a/scheme/cyclone/primitives.sld b/scheme/cyclone/primitives.sld index c461aa82..70012c1f 100644 --- a/scheme/cyclone/primitives.sld +++ b/scheme/cyclone/primitives.sld @@ -97,12 +97,11 @@ eqv? equal? Cyc-fast-member - ;assoc - ;assq - ;assv - ;memq - ;memv - ;member + Cyc-fast-assoc + assv + assq + memq + memv length set-car! set-cdr! @@ -224,12 +223,11 @@ (eqv? 2 2) (equal? 2 2) (Cyc-fast-member 2 2) - ;(assoc 2 2) - ;(assq 2 2) - ;(assv 2 2) - ;(memq 2 2) - ;(memv 2 2) - ;(member 2 2) + (Cyc-fast-assoc 2 2) + (assq 2 2) + (assv 2 2) + (memq 2 2) + (memv 2 2) (length 1 1) (set-car! 2 2) (set-cdr! 2 2) @@ -531,6 +529,11 @@ ((eq? p 'eqv?) "Cyc_eq") ((eq? p 'equal?) "equalp") ((eq? p 'Cyc-fast-member) "memberp") + ((eq? p 'Cyc-fast-assoc) "assoc") + ((eq? p 'assq) "assq") + ((eq? p 'assv) "assq") + ((eq? p 'memq) "memqp") + ((eq? p 'memv) "memqp") ((eq? p 'boolean?) "Cyc_is_boolean") ((eq? p 'char?) "Cyc_is_char") ((eq? p 'null?) "Cyc_is_null") @@ -576,6 +579,7 @@ >= <= Cyc-fast-member + Cyc-fast-assoc apply car cdr @@ -627,11 +631,11 @@ Cyc-installation-dir Cyc-compilation-environment command-line-arguments - ;assq - ;assv + assq + assv ;assoc - ;memq - ;memv + memq + memv ;member length set-car! diff --git a/scheme/eval.sld b/scheme/eval.sld index 9ba59db8..ba517bfe 100644 --- a/scheme/eval.sld +++ b/scheme/eval.sld @@ -199,12 +199,12 @@ (list 'eq? eq?) (list 'eqv? eqv?) (list 'equal? equal?) - ;(list 'assoc assoc) - ;(list 'assq assq) - ;(list 'assv assv) - ;(list 'memq memq) - ;(list 'memv memv) - ;(list 'member member) + ;(list 'Cyc-fast-assoc Cyc-fast-assoc) + (list 'assq assq) + (list 'assv assv) + (list 'memq memq) + (list 'memv memv) + ;(list 'Cyc-fast-member Cyc-fast-member) (list 'length length) (list 'set-car! set-car!) (list 'set-cdr! set-cdr!)