mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Fix type-checking of SRFI-1 `partition'.

Browse source
This commit is contained in:
Ludovic Courtès 2008-04-28 18:03:27 +02:00
parent a030cb4b16
commit 0fb11ae432
5 changed files with 31 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

1
NEWS
View file

@ -71,6 +71,7 @@ lead to a stack overflow.
** `(srfi srfi-35)' is now visible through `cond-expand' ** `(srfi srfi-35)' is now visible through `cond-expand'
** Fixed type-checking for the second argument of `eval' ** 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" ** Fixed `struct-ref' and `struct-set!' on "light structs"
** Honor struct field access rights in GOOPS ** Honor struct field access rights in GOOPS
** Changed the storage strategy of source properties, which fixes a deadlock ** Changed the storage strategy of source properties, which fixes a deadlock

5
srfi/ChangeLog
View file

@ -1,3 +1,8 @@
2008-04-28 Ludovic Courtès <ludo@gnu.org>
* srfi-1.c (scm_srfi1_partition): Properly type-check LIST.
Reported by Julian Graham <joolean@gmail.com>.
2008-04-27 Ludovic Courtès <ludo@gnu.org> 2008-04-27 Ludovic Courtès <ludo@gnu.org>
* srfi-1.c: Include <config.h>. * srfi-1.c: Include <config.h>.

11
srfi/srfi-1.c
View file

@ -1667,6 +1667,7 @@ SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
/* In this implementation, the output lists don't share memory with /* In this implementation, the output lists don't share memory with
list, because it's probably not worth the effort. */ list, because it's probably not worth the effort. */
scm_t_trampoline_1 call = scm_trampoline_1(pred); scm_t_trampoline_1 call = scm_trampoline_1(pred);
SCM orig_list = list;
SCM kept = scm_cons(SCM_EOL, SCM_EOL); SCM kept = scm_cons(SCM_EOL, SCM_EOL);
SCM kept_tail = kept; SCM kept_tail = kept;
SCM dropped = scm_cons(SCM_EOL, SCM_EOL); 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); SCM_ASSERT(call, pred, 2, FUNC_NAME);
for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) { for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
SCM elt = SCM_CAR(list); SCM elt, new_tail;
SCM new_tail = scm_cons(SCM_CAR(list), SCM_EOL);
/* 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))) { if (scm_is_true (call (pred, elt))) {
SCM_SETCDR(kept_tail, new_tail); SCM_SETCDR(kept_tail, new_tail);
kept_tail = new_tail; kept_tail = new_tail;

5
test-suite/ChangeLog
View file

@ -1,3 +1,8 @@
2008-04-28 Ludovic Courtès <ludo@gnu.org>
* tests/srfi-1.test (partition)[with improper list]: New test.
(partition!)[with improper list]: New test.
2008-04-26 Ludovic Courtès <ludo@gnu.org> 2008-04-26 Ludovic Courtès <ludo@gnu.org>
* standalone/Makefile.am (TESTS): Only add * standalone/Makefile.am (TESTS): Only add

14
test-suite/tests/srfi-1.test
View file

@ -1,6 +1,6 @@
;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- ;;;; 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 ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -2068,7 +2068,11 @@
(make-list 10000 1))) (make-list 10000 1)))
(lambda (even odd) (lambda (even odd)
(and (= (length odd) 10000) (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! ;; partition!
@ -2111,7 +2115,11 @@
(make-list 10000 1))) (make-list 10000 1)))
(lambda (even odd) (lambda (even odd)
(and (= (length odd) 10000) (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 ;; reduce