From 0fb11ae43259bfa3d07e2da97e644caaff65c477 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 Apr 2008 18:03:27 +0200 Subject: [PATCH] Fix type-checking of SRFI-1 `partition'. --- NEWS | 1 + srfi/ChangeLog | 5 +++++ srfi/srfi-1.c | 11 +++++++++-- test-suite/ChangeLog | 5 +++++ test-suite/tests/srfi-1.test | 14 +++++++++++--- 5 files changed, 31 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index f45d0aefe..ec3f37648 100644 --- a/NEWS +++ b/NEWS @@ -71,6 +71,7 @@ lead to a stack overflow. ** `(srfi srfi-35)' is now visible through `cond-expand' ** Fixed type-checking for the second argument of `eval' +** Fixed type-checking for SRFI-1 `partition' ** Fixed `struct-ref' and `struct-set!' on "light structs" ** Honor struct field access rights in GOOPS ** Changed the storage strategy of source properties, which fixes a deadlock diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 65ea3e982..1f6c599a8 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2008-04-28 Ludovic Courtès + + * srfi-1.c (scm_srfi1_partition): Properly type-check LIST. + Reported by Julian Graham . + 2008-04-27 Ludovic Courtès * srfi-1.c: Include . diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 2989a25cf..35815b32f 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -1667,6 +1667,7 @@ SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, /* In this implementation, the output lists don't share memory with list, because it's probably not worth the effort. */ scm_t_trampoline_1 call = scm_trampoline_1(pred); + SCM orig_list = list; SCM kept = scm_cons(SCM_EOL, SCM_EOL); SCM kept_tail = kept; SCM dropped = scm_cons(SCM_EOL, SCM_EOL); @@ -1675,8 +1676,14 @@ SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, SCM_ASSERT(call, pred, 2, FUNC_NAME); for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) { - SCM elt = SCM_CAR(list); - SCM new_tail = scm_cons(SCM_CAR(list), SCM_EOL); + SCM elt, new_tail; + + /* Make sure LIST is not a dotted list. */ + SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME); + + elt = SCM_CAR (list); + new_tail = scm_cons (SCM_CAR (list), SCM_EOL); + if (scm_is_true (call (pred, elt))) { SCM_SETCDR(kept_tail, new_tail); kept_tail = new_tail; diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index fa0fb7821..c2dc5aaed 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2008-04-28 Ludovic Courtès + + * tests/srfi-1.test (partition)[with improper list]: New test. + (partition!)[with improper list]: New test. + 2008-04-26 Ludovic Courtès * standalone/Makefile.am (TESTS): Only add diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 22c4a9a68..4f2838744 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1,6 +1,6 @@ ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +;;;; Copyright 2003, 2004, 2005, 2006, 2008 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 @@ -2068,7 +2068,11 @@ (make-list 10000 1))) (lambda (even odd) (and (= (length odd) 10000) - (= (length even) 0)))))) + (= (length even) 0))))) + + (pass-if-exception "with improper list" + exception:wrong-type-arg + (partition symbol? '(a b . c)))) ;; ;; partition! @@ -2111,7 +2115,11 @@ (make-list 10000 1))) (lambda (even odd) (and (= (length odd) 10000) - (= (length even) 0)))))) + (= (length even) 0))))) + + (pass-if-exception "with improper list" + exception:wrong-type-arg + (partition! symbol? (cons* 'a 'b 'c)))) ;; ;; reduce -- 2.20.1