* Added remq, remp, remv, and remove

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

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))

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]

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]

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]