mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-22 19:44:10 +02:00
Merge commit '29776e85da' into boehm-demers-weiser-gc
Conflicts: libguile/gc-card.c libguile/gc.c libguile/gc.h libguile/ports.c
This commit is contained in:
Ludovic Courtès
commit
6774820f1e
45 changed files with 2244 additions and 798 deletions
|
|
@ -1,3 +1,43 @@
|
|||
2007-09-03 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* tests/reader.test (reading)[block comment finishing sexp]: New
|
||||
test.
|
||||
|
||||
2007-08-26 Han-Wen Nienhuys <hanwen@lilypond.org>
|
||||
|
||||
* tests/ports.test ("port-for-each"): remove unresolved for
|
||||
port-for-each memory test.
|
||||
("fdes->port"): test fdes->port
|
||||
|
||||
2007-08-23 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* tests/reader.test (read-options)[positions on quote]: New
|
||||
test, proposed by Kevin Ryde.
|
||||
|
||||
2007-08-23 Kevin Ryde <user42@zip.com.au>
|
||||
|
||||
* tests/ports.test (port-for-each): New test for passing freed cell,
|
||||
marked as unresolved since problem not yet fixed.
|
||||
|
||||
2007-08-11 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* tests/srfi-35.test: New file.
|
||||
* Makefile.am (SCM_TESTS): Added `tests/srfi-35.test'.
|
||||
|
||||
2007-08-08 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* tests/srfi-9.test (exception:not-a-record): Removed.
|
||||
(accessor)[get-x on number, get-y on number]: Expect
|
||||
`exception:wrong-type-arg' instead of `exception:not-a-record'.
|
||||
(modifier)[set-y! on number]: Likewise
|
||||
|
||||
2007-07-25 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* tests/srfi-17.test (%some-variable): New.
|
||||
(set!)[target uses macro]: New test prefix. The
|
||||
"(set! (@@ ...) 1)" test is in accordance with Marius Vollmer's
|
||||
change in `libguile' dated 2003-11-17.
|
||||
|
||||
2007-07-22 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
* tests/reader.test: Added a proper header and `define-module'.
|
||||
|
|
@ -140,7 +180,7 @@
|
|||
|
||||
* tests/numbers.test (*): Exercise multiply by exact 0 giving exact 0.
|
||||
|
||||
2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
|
||||
2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
|
||||
|
||||
* tests/unif.test (syntax): New test prefix. Check syntax for
|
||||
negative lower bounds and negative lengths (reported by Gyula
|
||||
|
|
@ -167,7 +207,7 @@
|
|||
ensure intended exact vs inexact is checked. Reported by Aaron
|
||||
M. Ucko, Debian bug 396119.
|
||||
|
||||
2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
|
||||
2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
|
||||
|
||||
* test-suite/tests/vectors.test: Use `define-module'.
|
||||
(vector->list): New test prefix. "Shared array" test contributed
|
||||
|
|
@ -187,7 +227,7 @@
|
|||
|
||||
* tests/environments.test: Comment out all tests in this file.
|
||||
|
||||
2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
|
||||
2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
|
||||
|
||||
* tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a
|
||||
typo: `thrown' instead of `throw'.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
## Process this file with automake to produce Makefile.in.
|
||||
##
|
||||
## Copyright 2001, 2002, 2003, 2004, 2005, 2006 Software Foundation, Inc.
|
||||
## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007 Software Foundation, Inc.
|
||||
##
|
||||
## This file is part of GUILE.
|
||||
##
|
||||
|
|
@ -75,6 +75,7 @@ SCM_TESTS = tests/alist.test \
|
|||
tests/srfi-26.test \
|
||||
tests/srfi-31.test \
|
||||
tests/srfi-34.test \
|
||||
tests/srfi-35.test \
|
||||
tests/srfi-37.test \
|
||||
tests/srfi-39.test \
|
||||
tests/srfi-60.test \
|
||||
|
|
|
|||
|
|
@ -549,6 +549,44 @@
|
|||
(set-port-line! port n)
|
||||
(eqv? n (port-line port)))))
|
||||
|
||||
;;;
|
||||
;;; port-for-each
|
||||
;;;
|
||||
|
||||
(with-test-prefix "port-for-each"
|
||||
|
||||
;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
|
||||
;; its iterator func if a port was inaccessible in the last gc mark but
|
||||
;; the lazy sweeping has not yet reached it to remove it from the port
|
||||
;; table (scm_i_port_table). Provoking those gc conditions is a little
|
||||
;; tricky, but the following code made it happen in 1.8.2.
|
||||
(pass-if "passing freed cell"
|
||||
(let ((lst '()))
|
||||
;; clear out the heap
|
||||
(gc) (gc) (gc)
|
||||
;; allocate cells so the opened ports aren't at the start of the heap
|
||||
(make-list 1000)
|
||||
(open-input-file "/dev/null")
|
||||
(make-list 1000)
|
||||
(open-input-file "/dev/null")
|
||||
;; this gc leaves the above ports unmarked, ie. inaccessible
|
||||
(gc)
|
||||
;; but they're still in the port table, so this sees them
|
||||
(port-for-each (lambda (port)
|
||||
(set! lst (cons port lst))))
|
||||
;; this forces completion of the sweeping
|
||||
(gc) (gc) (gc)
|
||||
;; and (if the bug is present) the cells accumulated in LST are now
|
||||
;; freed cells, which give #f from `port?'
|
||||
(not (memq #f (map port? lst))))))
|
||||
|
||||
(with-test-prefix
|
||||
"fdes->port"
|
||||
(pass-if "fdes->ports finds port"
|
||||
(let ((port (open-file (test-file) "w")))
|
||||
|
||||
(not (not (memq port (fdes->ports (port->fdes port))))))))
|
||||
|
||||
;;;
|
||||
;;; seek
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -77,6 +77,10 @@
|
|||
(equal? '(+ 1 2 3)
|
||||
(read-string "(+ 1 #! this is a\ncomment !# 2 3)")))
|
||||
|
||||
(pass-if "block comment finishing s-exp"
|
||||
(equal? '(+ 2)
|
||||
(read-string "(+ 2 #! a comment\n!#\n) ")))
|
||||
|
||||
(pass-if "unprintable symbol"
|
||||
;; The reader tolerates unprintable characters for symbols.
|
||||
(equal? (string->symbol "\001\002\003")
|
||||
|
|
@ -151,6 +155,12 @@
|
|||
(let ((sexp (with-read-options '(positions)
|
||||
(lambda ()
|
||||
(read-string "(+ 1 2 3)")))))
|
||||
(and (equal? (source-property sexp 'line) 0)
|
||||
(equal? (source-property sexp 'column) 0))))
|
||||
(pass-if "positions on quote"
|
||||
(let ((sexp (with-read-options '(positions)
|
||||
(lambda ()
|
||||
(read-string "'abcde")))))
|
||||
(and (equal? (source-property sexp 'line) 0)
|
||||
(equal? (source-property sexp 'column) 0)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -48,6 +48,8 @@
|
|||
;; set!
|
||||
;;
|
||||
|
||||
(define %some-variable #f)
|
||||
|
||||
(with-test-prefix "set!"
|
||||
|
||||
(with-test-prefix "target is not procedure with setter"
|
||||
|
|
@ -58,7 +60,20 @@
|
|||
|
||||
(pass-if-exception "(set! '#f 1)"
|
||||
exception:bad-variable
|
||||
(eval '(set! '#f 1) (interaction-environment)))))
|
||||
(eval '(set! '#f 1) (interaction-environment))))
|
||||
|
||||
(with-test-prefix "target uses macro"
|
||||
|
||||
(pass-if "(set! (@@ ...) 1)"
|
||||
(eval '(set! (@@ (test-suite test-srfi-17) %some-variable) 1)
|
||||
(interaction-environment))
|
||||
(equal? %some-variable 1))
|
||||
|
||||
;; The `(quote x)' below used to be memoized as an infinite list before
|
||||
;; Guile 1.8.3.
|
||||
(pass-if-exception "(set! 'x 1)"
|
||||
exception:bad-variable
|
||||
(eval '(set! 'x 1) (interaction-environment)))))
|
||||
|
||||
;;
|
||||
;; setter
|
||||
|
|
|
|||
310
test-suite/tests/srfi-35.test
Normal file
310
test-suite/tests/srfi-35.test
Normal file
|
|
@ -0,0 +1,310 @@
|
|||
;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
|
||||
;;;; Ludovic Courtès <ludo@gnu.org>
|
||||
;;;;
|
||||
;;;; Copyright (C) 2007 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., 51 Franklin Street, Fifth Floor,
|
||||
;;;; Boston, MA 02110-1301 USA
|
||||
|
||||
(define-module (test-srfi-35)
|
||||
:use-module (test-suite lib)
|
||||
:use-module (srfi srfi-35))
|
||||
|
||||
|
||||
(with-test-prefix "condition types"
|
||||
(pass-if "&condition"
|
||||
(condition-type? &condition))
|
||||
|
||||
(pass-if "make-condition-type"
|
||||
(condition-type? (make-condition-type 'foo &condition '(a b)))))
|
||||
|
||||
|
||||
|
||||
(with-test-prefix "conditions"
|
||||
|
||||
(pass-if "&condition"
|
||||
(let ((c (make-condition &condition)))
|
||||
(and (condition? c)
|
||||
(condition-has-type? c &condition))))
|
||||
|
||||
(pass-if "simple condition"
|
||||
(let* ((ct (make-condition-type 'chbouib &condition '(a b)))
|
||||
(c (make-condition ct 'b 1 'a 0)))
|
||||
(and (condition? c)
|
||||
(condition-has-type? c ct))))
|
||||
|
||||
(pass-if "simple condition with inheritance"
|
||||
(let* ((top (make-condition-type 'foo &condition '(a b)))
|
||||
(ct (make-condition-type 'bar top '(c d)))
|
||||
(c (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
|
||||
(and (condition? c)
|
||||
(condition-has-type? c ct)
|
||||
(condition-has-type? c top))))
|
||||
|
||||
(pass-if "condition-ref"
|
||||
(let* ((ct (make-condition-type 'chbouib &condition '(a b)))
|
||||
(c (make-condition ct 'b 1 'a 0)))
|
||||
(and (eq? (condition-ref c 'a) 0)
|
||||
(eq? (condition-ref c 'b) 1))))
|
||||
|
||||
(pass-if "condition-ref with inheritance"
|
||||
(let* ((top (make-condition-type 'foo &condition '(a b)))
|
||||
(ct (make-condition-type 'bar top '(c d)))
|
||||
(c (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
|
||||
(and (eq? (condition-ref c 'a) 0)
|
||||
(eq? (condition-ref c 'b) 1)
|
||||
(eq? (condition-ref c 'c) 2)
|
||||
(eq? (condition-ref c 'd) 3))))
|
||||
|
||||
(pass-if "extract-condition"
|
||||
(let* ((ct (make-condition-type 'chbouib &condition '(a b)))
|
||||
(c (make-condition ct 'b 1 'a 0)))
|
||||
(equal? c (extract-condition c ct)))))
|
||||
|
||||
|
||||
(with-test-prefix "compound conditions"
|
||||
(pass-if "condition-has-type?"
|
||||
(let* ((t1 (make-condition-type 'foo &condition '(a b)))
|
||||
(t2 (make-condition-type 'bar &condition '(c d)))
|
||||
(c1 (make-condition t1 'a 0 'b 1))
|
||||
(c2 (make-condition t2 'c 2 'd 3))
|
||||
(c (make-compound-condition c1 c2)))
|
||||
(and (condition? c)
|
||||
(condition-has-type? c t1)
|
||||
(condition-has-type? c t2))))
|
||||
|
||||
(pass-if "condition-ref"
|
||||
(let* ((t1 (make-condition-type 'foo &condition '(a b)))
|
||||
(t2 (make-condition-type 'bar &condition '(c d)))
|
||||
(c1 (make-condition t1 'a 0 'b 1))
|
||||
(c2 (make-condition t2 'c 2 'd 3))
|
||||
(c (make-compound-condition c1 c2)))
|
||||
(equal? (map (lambda (field)
|
||||
(condition-ref c field))
|
||||
'(a b c d))
|
||||
'(0 1 2 3))))
|
||||
|
||||
(pass-if "condition-ref with same-named fields"
|
||||
(let* ((t1 (make-condition-type 'foo &condition '(a b)))
|
||||
(t2 (make-condition-type 'bar &condition '(a c d)))
|
||||
(c1 (make-condition t1 'a 0 'b 1))
|
||||
(c2 (make-condition t2 'a -1 'c 2 'd 3))
|
||||
(c (make-compound-condition c1 c2)))
|
||||
(equal? (map (lambda (field)
|
||||
(condition-ref c field))
|
||||
'(a b c d))
|
||||
'(0 1 2 3))))
|
||||
|
||||
(pass-if "extract-condition"
|
||||
(let* ((t1 (make-condition-type 'foo &condition '(a b)))
|
||||
(t2 (make-condition-type 'bar &condition '(c d)))
|
||||
(c1 (make-condition t1 'a 0 'b 1))
|
||||
(c2 (make-condition t2 'c 2 'd 3))
|
||||
(c (make-compound-condition c1 c2)))
|
||||
(and (equal? c1 (extract-condition c t1))
|
||||
(equal? c2 (extract-condition c t2)))))
|
||||
|
||||
(pass-if "extract-condition with same-named fields"
|
||||
(let* ((t1 (make-condition-type 'foo &condition '(a b)))
|
||||
(t2 (make-condition-type 'bar &condition '(a c)))
|
||||
(c1 (make-condition t1 'a 0 'b 1))
|
||||
(c2 (make-condition t2 'a -1 'c 2))
|
||||
(c (make-compound-condition c1 c2)))
|
||||
(and (equal? c1 (extract-condition c t1))
|
||||
(equal? c2 (extract-condition c t2))))))
|
||||
|
||||
|
||||
|
||||
(with-test-prefix "syntax"
|
||||
(pass-if "define-condition-type"
|
||||
(let ((m (current-module)))
|
||||
(eval '(define-condition-type &chbouib &condition
|
||||
chbouib?
|
||||
(one chbouib-one)
|
||||
(two chbouib-two))
|
||||
m)
|
||||
(eval '(and (condition-type? &chbouib)
|
||||
(procedure? chbouib?)
|
||||
(let ((c (make-condition &chbouib 'one 1 'two 2)))
|
||||
(and (condition? c)
|
||||
(chbouib? c)
|
||||
(eq? (chbouib-one c) 1)
|
||||
(eq? (chbouib-two c) 2))))
|
||||
m)))
|
||||
|
||||
(pass-if "condition"
|
||||
(let* ((t (make-condition-type 'chbouib &condition '(a b)))
|
||||
(c (condition (t (b 2) (a 1)))))
|
||||
(and (condition? c)
|
||||
(condition-has-type? c t)
|
||||
(equal? (map (lambda (f)
|
||||
(condition-ref c f))
|
||||
'(a b))
|
||||
'(1 2)))))
|
||||
|
||||
(pass-if-exception "condition with missing fields"
|
||||
exception:miscellaneous-error
|
||||
(let ((t (make-condition-type 'chbouib &condition '(a b c))))
|
||||
(condition (t (a 1) (b 2)))))
|
||||
|
||||
(pass-if "compound condition"
|
||||
(let* ((t1 (make-condition-type 'foo &condition '(a b)))
|
||||
(t2 (make-condition-type 'bar &condition '(c d)))
|
||||
(c1 (make-condition t1 'a 0 'b 1))
|
||||
(c2 (make-condition t2 'c 2 'd 3))
|
||||
(c (condition (t1 (a 0) (b 1))
|
||||
(t2 (c 2) (d 3)))))
|
||||
(and (equal? c1 (extract-condition c t1))
|
||||
(equal? c2 (extract-condition c t2))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Examples from the SRFI.
|
||||
;;;
|
||||
|
||||
(define-condition-type &c &condition
|
||||
c?
|
||||
(x c-x))
|
||||
|
||||
(define-condition-type &c1 &c
|
||||
c1?
|
||||
(a c1-a))
|
||||
|
||||
(define-condition-type &c2 &c
|
||||
c2?
|
||||
(b c2-b))
|
||||
|
||||
(define v1
|
||||
(make-condition &c1 'x "V1" 'a "a1"))
|
||||
|
||||
(define v2
|
||||
(condition (&c2 (x "V2") (b "b2"))))
|
||||
|
||||
(define v3
|
||||
(condition (&c1 (x "V3/1") (a "a3"))
|
||||
(&c2 (b "b3"))))
|
||||
|
||||
(define v4
|
||||
(make-compound-condition v1 v2))
|
||||
|
||||
(define v5
|
||||
(make-compound-condition v2 v3))
|
||||
|
||||
|
||||
(with-test-prefix "examples"
|
||||
|
||||
(pass-if "v1"
|
||||
(condition? v1))
|
||||
|
||||
(pass-if "(c? v1)"
|
||||
(c? v1))
|
||||
|
||||
(pass-if "(c1? v1)"
|
||||
(c1? v1))
|
||||
|
||||
(pass-if "(not (c2? v1))"
|
||||
(not (c2? v1)))
|
||||
|
||||
(pass-if "(c-x v1)"
|
||||
(equal? (c-x v1) "V1"))
|
||||
|
||||
(pass-if "(c1-a v1)"
|
||||
(equal? (c1-a v1) "a1"))
|
||||
|
||||
|
||||
(pass-if "v2"
|
||||
(condition? v2))
|
||||
|
||||
(pass-if "(c? v2)"
|
||||
(c? v2))
|
||||
|
||||
(pass-if "(c2? v2)"
|
||||
(c2? v2))
|
||||
|
||||
(pass-if "(not (c1? v2))"
|
||||
(not (c1? v2)))
|
||||
|
||||
(pass-if "(c-x v2)"
|
||||
(equal? (c-x v2) "V2"))
|
||||
|
||||
(pass-if "(c2-b v2)"
|
||||
(equal? (c2-b v2) "b2"))
|
||||
|
||||
|
||||
(pass-if "v3"
|
||||
(condition? v3))
|
||||
|
||||
(pass-if "(c? v3)"
|
||||
(c? v3))
|
||||
|
||||
(pass-if "(c1? v3)"
|
||||
(c1? v3))
|
||||
|
||||
(pass-if "(c2? v3)"
|
||||
(c2? v3))
|
||||
|
||||
(pass-if "(c-x v3)"
|
||||
(equal? (c-x v3) "V3/1"))
|
||||
|
||||
(pass-if "(c1-a v3)"
|
||||
(equal? (c1-a v3) "a3"))
|
||||
|
||||
(pass-if "(c2-b v3)"
|
||||
(equal? (c2-b v3) "b3"))
|
||||
|
||||
|
||||
(pass-if "v4"
|
||||
(condition? v4))
|
||||
|
||||
(pass-if "(c? v4)"
|
||||
(c? v4))
|
||||
|
||||
(pass-if "(c1? v4)"
|
||||
(c1? v4))
|
||||
|
||||
(pass-if "(c2? v4)"
|
||||
(c2? v4))
|
||||
|
||||
(pass-if "(c-x v4)"
|
||||
(equal? (c-x v4) "V1"))
|
||||
|
||||
(pass-if "(c1-a v4)"
|
||||
(equal? (c1-a v4) "a1"))
|
||||
|
||||
(pass-if "(c2-b v4)"
|
||||
(equal? (c2-b v4) "b2"))
|
||||
|
||||
|
||||
(pass-if "v5"
|
||||
(condition? v5))
|
||||
|
||||
(pass-if "(c? v5)"
|
||||
(c? v5))
|
||||
|
||||
(pass-if "(c1? v5)"
|
||||
(c1? v5))
|
||||
|
||||
(pass-if "(c2? v5)"
|
||||
(c2? v5))
|
||||
|
||||
(pass-if "(c-x v5)"
|
||||
(equal? (c-x v5) "V2"))
|
||||
|
||||
(pass-if "(c1-a v5)"
|
||||
(equal? (c1-a v5) "a3"))
|
||||
|
||||
(pass-if "(c2-b v5)"
|
||||
(equal? (c2-b v5) "b2")))
|
||||
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
|
||||
;;;; Martin Grabmueller, 2001-05-10
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2001, 2006, 2007 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
|
||||
|
|
@ -23,10 +23,6 @@
|
|||
#:use-module (srfi srfi-9))
|
||||
|
||||
|
||||
(define exception:not-a-record
|
||||
(cons 'misc-error "^not-a-record"))
|
||||
|
||||
|
||||
(define-record-type :foo (make-foo x) foo?
|
||||
(x get-x) (y get-y set-y!))
|
||||
|
||||
|
|
@ -61,9 +57,9 @@
|
|||
(pass-if "get-y"
|
||||
(= 2 (get-y f)))
|
||||
|
||||
(pass-if-exception "get-x on number" exception:not-a-record
|
||||
(pass-if-exception "get-x on number" exception:wrong-type-arg
|
||||
(get-x 999))
|
||||
(pass-if-exception "get-y on number" exception:not-a-record
|
||||
(pass-if-exception "get-y on number" exception:wrong-type-arg
|
||||
(get-y 999))
|
||||
|
||||
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
|
||||
|
|
@ -78,7 +74,7 @@
|
|||
(set-y! f #t)
|
||||
(eq? #t (get-y f)))
|
||||
|
||||
(pass-if-exception "set-y! on number" exception:not-a-record
|
||||
(pass-if-exception "set-y! on number" exception:wrong-type-arg
|
||||
(set-y! 999 #t))
|
||||
|
||||
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue