mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
c0f6c1638b
* module/rnrs/base.scm (error, assert): Define -- they were missing. (assertion-violation): Properly treat a #f `who' argument. * module/rnrs/conditions.scm (condition): Use `assertion-violation' instead of the undefined `raise'. (define-condition-type): Fix for multiple fields. * test-suite/tests/r6rs-conditions.test: Test accessors of a multiple-field condition. Also import `(rnrs base)' to allow stand-alone running of the tests; apparently the `@' references scattered throughout the R6RS modules make the libraries sensitive to their load order -- for instance, trying to load `(rnrs conditions)' before `(rnrs base)' is loaded fails. * module/rnrs/records/inspection.scm: Use `assertion-violation' instead of an explicit `raise'. * module/rnrs/records/syntactic.scm (process-fields): Use `syntax-violation' instead of bogus invocations of `error'.
111 lines
4.2 KiB
Text
111 lines
4.2 KiB
Text
;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)
|
||
|
||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||
;;
|
||
;; This library is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU Lesser General Public
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 3 of the License, or (at your option) any later version.
|
||
;;
|
||
;; This library 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
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(define-module (test-suite test-rnrs-conditions)
|
||
:use-module ((rnrs base) :version (6))
|
||
:use-module ((rnrs conditions) :version (6))
|
||
:use-module (test-suite lib))
|
||
|
||
(define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
|
||
(define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
|
||
(define-condition-type &c &condition make-c-condition c-condition?
|
||
(baz c-baz)
|
||
(qux c-qux)
|
||
(frobotz c-frobotz))
|
||
|
||
(with-test-prefix "condition?"
|
||
(pass-if "condition? is #t for simple conditions"
|
||
(condition? (make-error)))
|
||
|
||
(pass-if "condition? is #t for compound conditions"
|
||
(condition? (condition (make-error) (make-assertion-violation))))
|
||
|
||
(pass-if "condition? is #f for non-conditions"
|
||
(not (condition? 'foo))))
|
||
|
||
(with-test-prefix "simple-conditions"
|
||
(pass-if "simple-conditions returns condition components"
|
||
(let* ((error (make-error))
|
||
(assertion (make-assertion-violation))
|
||
(c (condition error assertion))
|
||
(scs (simple-conditions c)))
|
||
(equal? scs (list error assertion))))
|
||
|
||
(pass-if "simple-conditions flattens compound conditions"
|
||
(let* ((implementation-restriction
|
||
(make-implementation-restriction-violation))
|
||
(error1 (make-error))
|
||
(c1 (condition implementation-restriction error1))
|
||
(error2 (make-error))
|
||
(assertion (make-assertion-violation))
|
||
(c2 (condition error2 assertion c1))
|
||
(scs (simple-conditions c2)))
|
||
(equal? scs (list error2 assertion implementation-restriction error1)))))
|
||
|
||
(with-test-prefix "condition-predicate"
|
||
(pass-if "returned procedure identifies matching simple conditions"
|
||
(let ((mp (condition-predicate &message))
|
||
(mc (make-message-condition "test")))
|
||
(mp mc)))
|
||
|
||
(pass-if "returned procedure identifies matching compound conditions"
|
||
(let* ((sp (condition-predicate &serious))
|
||
(vp (condition-predicate &violation))
|
||
(sc (make-serious-condition))
|
||
(vc (make-violation))
|
||
(c (condition sc vc)))
|
||
(and (sp c) (vp c))))
|
||
|
||
(pass-if "returned procedure is #f for non-matching simple"
|
||
(let ((sp (condition-predicate &serious)))
|
||
(not (sp 'foo))))
|
||
|
||
(pass-if "returned procedure is #f for compound without match"
|
||
(let* ((ip (condition-predicate &irritants))
|
||
(sc (make-serious-condition))
|
||
(vc (make-violation))
|
||
(c (condition sc vc)))
|
||
(not (ip c)))))
|
||
|
||
(with-test-prefix "condition-accessor"
|
||
(pass-if "accessor applies proc to field from simple condition"
|
||
(let* ((proc (lambda (c) (condition-message c)))
|
||
(ma (condition-accessor &message proc))
|
||
(mc (make-message-condition "foo")))
|
||
(equal? (ma mc) "foo")))
|
||
|
||
(pass-if "accessor applies proc to field from compound condition"
|
||
(let* ((proc (lambda (c) (condition-message c)))
|
||
(ma (condition-accessor &message proc))
|
||
(mc (make-message-condition "foo"))
|
||
(vc (make-violation))
|
||
(c (condition vc mc)))
|
||
(equal? (ma c) "foo"))))
|
||
|
||
(with-test-prefix "define-condition-type"
|
||
(pass-if "define-condition-type produces proper accessors"
|
||
(let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
|
||
(and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
|
||
(pass-if "define-condition-type works for multiple fields"
|
||
(let ((c (condition (make-a-condition 'foo)
|
||
(make-c-condition 1 2 3))))
|
||
(and (eq? (a-foo c) 'foo)
|
||
(= (c-baz c) 1)
|
||
(= (c-qux c) 2)
|
||
(= (c-frobotz c) 3)))))
|