srfi-1 take and drop

* srfi-1 take and drop
@ 2003-05-05 23:14 Kevin Ryde
  2003-05-06  1:30 ` Rob Browning
  0 siblings, 1 reply; 10+ messages in thread
From: Kevin Ryde @ 2003-05-05 23:14 UTC (permalink / raw)


[-- Attachment #1: Type: text/plain, Size: 617 bytes --]

Am I right that srfi-1 take and drop are the same as the core
list-head and list-tail?  In which case perhaps,

        * srfi-1.scm (take): Make this an alias for list-head.
        (drop): Make this an alias for list-tail.

        * tests/srfi-1.test: New file, exercising take and drop.
        * Makefile.am (SCM_TESTS): Add it.

The only difference I could spot in the current implementations was
list-head and list-tail throw an exception for negative n, where take
and drop code quietly treat that as 0.  srfi-1 doesn't say anything
about negatives as far as I can tell, so presumably there's a free
choice.


[-- Attachment #2: srfi-1.test --]
[-- Type: text/plain, Size: 3598 bytes --]

;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
;;;;
;;;; Copyright 2003 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA

(use-modules (srfi srfi-1)
	     (test-suite lib))


;;
;; drop
;;

(with-test-prefix "drop"
  
  (pass-if "'() 0"
    (null? (drop '() 0)))
  
  (pass-if "'(a) 0"
    (let ((lst '(a)))
      (eq? lst
	   (drop lst 0))))
  
  (pass-if "'(a b) 0"
    (let ((lst '(a b)))
      (eq? lst
	   (drop lst 0))))
  
  (pass-if "'(a) 1"
    (let ((lst '(a)))
      (eq? (cdr lst)
	   (drop lst 1))))
  
  (pass-if "'(a b) 1"
    (let ((lst '(a b)))
      (eq? (cdr lst)
	   (drop lst 1))))
  
  (pass-if "'(a b) 2"
    (let ((lst '(a b)))
      (eq? (cddr lst)
	   (drop lst 2))))
  
  (pass-if "'(a b c) 1"
    (let ((lst '(a b c)))
      (eq? (cddr lst)
	   (drop lst 2))))
  
  (pass-if "circular '(a) 0"
    (let ((lst (circular-list 'a)))
      (eq? lst
	   (drop lst 0))))
  
  (pass-if "circular '(a) 1"
    (let ((lst (circular-list 'a)))
      (eq? lst
	   (drop lst 1))))
  
  (pass-if "circular '(a) 2"
    (let ((lst (circular-list 'a)))
      (eq? lst
	   (drop lst 1))))
  
  (pass-if "circular '(a b) 1"
    (let ((lst (circular-list 'a)))
      (eq? (cdr lst)
	   (drop lst 0))))
  
  (pass-if "circular '(a b) 2"
    (let ((lst (circular-list 'a)))
      (eq? lst
	   (drop lst 1))))
  
  (pass-if "circular '(a b) 5"
    (let ((lst (circular-list 'a)))
      (eq? (cdr lst)
	   (drop lst 5))))
  
  (pass-if "'(a . b) 1"
    (eq? 'b
	 (drop '(a . b) 1)))
  
  (pass-if "'(a b . c) 1"
    (equal? 'c
	    (drop '(a b . c) 2))))

;;
;; take
;;

(with-test-prefix "take"
  
  (pass-if "'() 0"
    (null? (take '() 0)))
  
  (pass-if "'(a) 0"
    (null? (take '(a) 0)))
  
  (pass-if "'(a b) 0"
    (null? (take '() 0)))
  
  (pass-if "'(a b c) 0"
    (null? (take '() 0)))
  
  (pass-if "'(a) 1"
    (let* ((lst '(a))
	   (got (take lst 1)))
      (and (equal? '(a) got)
	   (not (eq? lst got)))))
  
  (pass-if "'(a b) 1"
    (equal? '(a)
	    (take '(a b) 1)))
  
  (pass-if "'(a b c) 1"
    (equal? '(a)
	    (take '(a b c) 1)))
  
  (pass-if "'(a b) 2"
    (let* ((lst '(a b))
	   (got (take lst 2)))
      (and (equal? '(a b) got)
	   (not (eq? lst got)))))
  
  (pass-if "'(a b c) 2"
    (equal? '(a b)
	    (take '(a b c) 2)))
  
  (pass-if "circular '(a) 0"
    (equal? '()
	    (take (circular-list 'a) 0)))
  
  (pass-if "circular '(a) 1"
    (equal? '(a)
	    (take (circular-list 'a) 1)))
  
  (pass-if "circular '(a) 2"
    (equal? '(a a)
	    (take (circular-list 'a) 2)))
  
  (pass-if "circular '(a b) 5"
    (equal? '(a b a b a)
	    (take (circular-list 'a 'b) 5)))
  
  (pass-if "'(a . b) 1"
    (equal? '(a)
	    (take '(a . b) 1)))
  
  (pass-if "'(a b . c) 1"
    (equal? '(a)
	    (take '(a b . c) 1)))
  
  (pass-if "'(a b . c) 2"
    (equal? '(a b)
	    (take '(a b . c) 2))))

[-- Attachment #3: srfi-1.scm.take-drop.diff --]
[-- Type: text/plain, Size: 559 bytes --]

--- srfi-1.scm.~1.22.~	2003-04-28 07:51:30.000000000 +1000
+++ srfi-1.scm	2003-05-05 11:23:36.000000000 +1000
@@ -347,16 +347,9 @@
 
 (define (car+cdr x) (values (car x) (cdr x)))
 
-(define (take x i)
-  (let lp ((n i) (l x) (acc '()))
-    (if (<= n 0)
-      (reverse! acc)
-      (lp (- n 1) (cdr l) (cons (car l) acc)))))
-(define (drop x i)
-  (let lp ((n i) (l x))
-    (if (<= n 0)
-      l
-      (lp (- n 1) (cdr l)))))
+(define take list-head)
+(define drop list-tail)
+
 (define (take-right flist i)
   (let lp ((n i) (l flist))
     (if (<= n 0)

[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel

^ permalink raw reply	[flat|nested] 10+ messages in thread