From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Kevin Ryde Newsgroups: gmane.lisp.guile.devel Subject: srfi-1 delete and delete! Date: Sun, 22 Jun 2003 10:17:36 +1000 Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Message-ID: <87y8zvklsv.fsf@zip.com.au> NNTP-Posting-Host: main.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: main.gmane.org 1056241247 27288 80.91.224.249 (22 Jun 2003 00:20:47 GMT) X-Complaints-To: usenet@main.gmane.org NNTP-Posting-Date: Sun, 22 Jun 2003 00:20:47 +0000 (UTC) Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Jun 22 02:20:46 2003 Return-path: Original-Received: from monty-python.gnu.org ([199.232.76.173]) by main.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 19Tsb7-000760-00 for ; Sun, 22 Jun 2003 02:20:46 +0200 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.20) id 19TsbH-0007Dq-55 for guile-devel@m.gmane.org; Sat, 21 Jun 2003 20:20:55 -0400 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.20) id 19Tsab-00075N-59 for guile-devel@gnu.org; Sat, 21 Jun 2003 20:20:13 -0400 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.20) id 19TsYS-0005dz-V0 for guile-devel@gnu.org; Sat, 21 Jun 2003 20:18:08 -0400 Original-Received: from snoopy.pacific.net.au ([61.8.0.36]) by monty-python.gnu.org with esmtp (Exim 4.20) id 19TsYO-0005Ff-85 for guile-devel@gnu.org; Sat, 21 Jun 2003 20:17:56 -0400 Original-Received: from sunny.pacific.net.au (sunny.pacific.net.au [203.2.228.40]) h5M0HqYd031863 for ; Sun, 22 Jun 2003 10:17:52 +1000 Original-Received: from wisma.pacific.net.au (wisma.pacific.net.au [210.23.129.72]) by sunny.pacific.net.au with ESMTP id h5M0HqQg014037 for ; Sun, 22 Jun 2003 10:17:52 +1000 (EST) Original-Received: from localhost (ppp116.dyn228.pacific.net.au [203.143.228.116]) by wisma.pacific.net.au (8.12.9/8.12.9) with ESMTP id h5M0Hlnh013405 for ; Sun, 22 Jun 2003 10:17:50 +1000 (EST) Original-Received: from gg by localhost with local (Exim 3.35 #1 (Debian)) id 19TsY4-0003wj-00; Sun, 22 Jun 2003 10:17:36 +1000 Original-To: guile-devel@gnu.org Mail-Copies-To: never User-Agent: Gnus/5.090019 (Oort Gnus v0.19) Emacs/21.2 (gnu/linux) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1b5 Precedence: list List-Id: Developers list for Guile, the GNU extensibility library List-Help: List-Post: List-Subscribe: , List-Archive: List-Unsubscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: main.gmane.org gmane.lisp.guile.devel:2570 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.devel:2570 This is new srfi-1 delete and delete!, as threatened. They avoid the non-tail-recursions in the current code, and delete saves consing by tail sharing, as the spec allows. For the two-arg case the plain core delete/delete! is called, so there's no loss of efficiency when using the srfi-1 module. The current core delete doesn't do tail sharing, I wonder if that's something it (and friends) could get. Code and test cases below, for contemplation. delete! is a warmed over copy of the core code, delete is new. SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0, (SCM x, SCM lst, SCM pred), "Return a list containing the elements of @var{lst} but with\n" "those equal to @var{x} deleted. The returned elements will be\n" "in the same order as they were in @var{lst}.\n" "\n" "Equality is determined by @var{pred}, or @code{equal?} if not\n" "given. An equality call is made just once for each element,\n" "but the order in which the calls are made on the elements is\n" "unspecified.\n" "\n" "The equality calls are always @code{(pred x elem)}, ie.@: the\n" "given @var{x} is first. This means for instance elements\n" "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n" "\n" "@var{lst} is not modified, but the returned list might share a\n" "common tail with @var{lst}.") #define FUNC_NAME s_scm_srfi1_delete { scm_t_trampoline_2 equal_p; SCM ret, *p, keeplst; if (SCM_UNBNDP (pred)) return scm_delete (x, lst); equal_p = scm_trampoline_2 (pred); SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME); /* ret is the return list being constructed. p is where to append to it, initially &ret then the SCM_CDRLOC of the last pair. lst progresses as elements are considered. Elements to be retained are not immediately copied, instead keeplst is the last pair in lst which is to be retained but not yet copied. When there's no more deletions, *p can be set to keeplst to share the remainder of the original lst. (The entire original lst if there's no deletions at all.) */ keeplst = lst; ret = SCM_EOL; p = &ret; for ( ; SCM_CONSP (lst); lst = SCM_CDR (lst)) { if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (lst)))) { /* delete this element, so copy from keeplst (inclusive) to lst (exclusive) onto ret */ while (keeplst != lst) { SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL); *p = c; p = SCM_CDRLOC (c); keeplst = SCM_CDR (keeplst); } keeplst = SCM_CDR (lst); } } /* final retained elements */ *p = keeplst; /* demand that lst was a proper list */ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); return ret; } #undef FUNC_NAME SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0, (SCM x, SCM lst, SCM pred), "Return a list containing the elements of @var{lst} but with\n" "those equal to @var{x} deleted. The returned elements will be\n" "in the same order as they were in @var{lst}.\n" "\n" "Equality is determined by @var{pred}, or @code{equal?} if not\n" "given. An equality call is made just once for each element,\n" "but the order in which the calls are made on the elements is\n" "unspecified.\n" "\n" "The equality calls are always @code{(pred x elem)}, ie.@: the\n" "given @var{x} is first. This means for instance elements\n" "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n" "\n" "@var{lst} may be modified to construct the returned list.") #define FUNC_NAME s_scm_srfi1_delete_x { scm_t_trampoline_2 equal_p; SCM walk; SCM *prev; if (SCM_UNBNDP (pred)) return scm_delete_x (x, lst); equal_p = scm_trampoline_2 (pred); SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME); for (prev = &lst, walk = lst; SCM_CONSP (walk); walk = SCM_CDR (walk)) { if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (walk)))) *prev = SCM_CDR (walk); else prev = SCM_CDRLOC (walk); } /* demand the input was a proper list */ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME, "list"); return lst; } #undef FUNC_NAME (define (ref-delete x lst . proc) "Reference implemenation of srfi-1 `delete'." (set! proc (if (null? proc) equal? (car proc))) (do ((ret '()) (lst lst (cdr lst))) ((null? lst) (reverse! ret)) (if (not (proc x (car lst))) (set! ret (cons (car lst) ret))))) ;; ;; delete and delete! ;; (let () ;; Call (PROC lst) for all lists of length up to 6, with all combinations ;; of elements to be retained (numbers 0 upwards) or deleted (#f). (define (test-lists proc) (do ((n 0 (1+ n))) ((>= n 6)) (do ((limit (ash 1 n)) (i 0 (1+ i))) ((>= i limit)) (let ((lst '())) (do ((bit 0 (1+ bit))) ((>= bit n)) (set! lst (cons (if (logbit? bit i) bit #f) lst))) (proc lst))))) (define (common-tests delete-proc) (pass-if-exception "too few args" exception:wrong-num-args (delete-proc 0)) (pass-if-exception "too many args" exception:wrong-num-args (delete-proc 0 '() equal? 99)) (pass-if "empty" (eq? '() (delete-proc 0 '()))) (pass-if "equal? (default)" (equal? '((1) (3)) (delete-proc '(2) '((1) (2) (3))))) (pass-if "eq?" (equal? '((1) (2) (3)) (delete-proc '(2) '((1) (2) (3)) eq?))) (pass-if "called arg order" (equal? '(1 2 3) (delete-proc 3 '(1 2 3 4 5) <)))) (with-test-prefix "delete" (common-tests delete) (test-lists (lambda (lst) (let ((lst-copy (list-copy lst))) (with-test-prefix lst-copy (pass-if "result" (equal? (delete #f lst) (ref-delete #f lst))) (pass-if "non-destructive" (equal? lst-copy lst))))))) (with-test-prefix "delete!" (common-tests delete!) (test-lists (lambda (lst) (pass-if lst (equal? (delete! #f lst) (ref-delete #f lst))))))) _______________________________________________ Guile-devel mailing list Guile-devel@gnu.org http://mail.gnu.org/mailman/listinfo/guile-devel