diff --git a/src/ikarus.boot b/src/ikarus.boot index d5cc82d..1c93710 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.lists.ss b/src/ikarus.lists.ss index cc4a2f7..6f537c5 100644 --- a/src/ikarus.lists.ss +++ b/src/ikarus.lists.ss @@ -2,13 +2,14 @@ (library (ikarus lists) (export $memq list? list cons* make-list append length list-ref reverse last-pair memq memp memv member assq assp assv assoc - map for-each andmap ormap list-tail) + remq remv remove remp map for-each andmap ormap list-tail) (import (ikarus system $fx) (ikarus system $pairs) (except (ikarus) list? list cons* make-list append reverse last-pair length list-ref memq memp memv member assq - assp assv assoc map for-each andmap ormap list-tail)) + assp assv assoc remq remv remove remp + map for-each andmap ormap list-tail)) (define $memq (lambda (x ls) @@ -389,6 +390,51 @@ (lambda (x ls) (race x ls ls ls)))) + + (module (remq remv remove remp) + (define-syntax define-remover + (syntax-rules () + [(_ name cmp check) + (define name + (letrec ([race + (lambda (h t ls x) + (if (pair? h) + (if (cmp ($car h) x) + (let ([h ($cdr h)]) + (if (pair? h) + (if (not (eq? h t)) + (if (cmp ($car h) x) + (race ($cdr h) ($cdr t) ls x) + (cons ($car h) (race ($cdr h) ($cdr t) ls x))) + (error 'name "circular list ~s" ls)) + (if (null? h) + '() + (error 'name "~s is not a proper list" ls)))) + (let ([a0 ($car h)] [h ($cdr h)]) + (if (pair? h) + (if (not (eq? h t)) + (if (cmp ($car h) x) + (cons a0 (race ($cdr h) ($cdr t) ls x)) + (cons* a0 ($car h) (race ($cdr h) ($cdr t) ls x))) + (error 'name "circular list ~s" ls)) + (if (null? h) + (list a0) + (error 'name "~s is not a proper list" ls))))) + (if (null? h) + '() + (error 'name "~s is not a proper list" ls))))]) + (lambda (x ls) + (check x ls) + (race ls ls ls x))))])) + (define-remover remq eq? (lambda (x ls) #t)) + (define-remover remv eqv? (lambda (x ls) #t)) + (define-remover remove equal? (lambda (x ls) #t)) + (define-remover remp (lambda (elt p) (p elt)) + (lambda (x ls) + (unless (procedure? x) + (error 'remp "~s is not a procedure" x))))) + + (module (map) (define who 'map) (define len diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index 08b0119..eee3c63 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -1123,7 +1123,7 @@ (begin (define (add-frm x s) (set-add (fvar-idx x) s)) (define (rem-nfv x s) - (remq x s)) + (remq1 x s)) (define (init-var! x i) (set-var-index! x i) (set-var-var-move! x (empty-var-set)) diff --git a/src/makefile.ss b/src/makefile.ss index 1f2e373..be2cf84 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -328,6 +328,10 @@ [memp i r] [memv i r] [member i r] + [remq i] + [remp i] + [remv i] + [remove i] [list-sort i] [vector-sort i] [vector-sort! i] diff --git a/src/set-operations.ss b/src/set-operations.ss index 21cd9f5..6cd1b57 100644 --- a/src/set-operations.ss +++ b/src/set-operations.ss @@ -1,10 +1,11 @@ -(define (remq x ls) + +(define (remq1 x ls) (cond [(null? ls) '()] [(eq? x (car ls)) (cdr ls)] [else - (let ([t (remq x (cdr ls))]) + (let ([t (remq1 x (cdr ls))]) (cond [(eq? t (cdr ls)) ls] [else (cons (car ls) t)]))])) @@ -29,7 +30,7 @@ (define (rem* s1 s2) (cond [(null? s1) s2] - [else (remq (car s1) (rem* (cdr s1) s2))])) + [else (remq1 (car s1) (rem* (cdr s1) s2))])) (cond [(null? s1) '()] [(null? s2) s1] diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index 0be9f45..63caf1f 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -515,10 +515,10 @@ [memq C ls se] [memv C ls se] [partition S ls] - [remove S ls] + [remq C ls] [remp S ls] - [remq S ls] [remv S ls] + [remove S ls] ;;; [set-car! C mp se] [set-cdr! C mp se]