Ticket #474: condition_list.patch

File condition_list.patch, 3.6 KB (added by Christian Kellermann, 13 years ago)

patch against git experimental branch commit 35e6429e4f4397c654cec39e0d2bc5cf42073a8d

  • library.scm 

    From 066b81e8be4240f5ad75b8299e2ae5afd77c7200 Mon Sep 17 00:00:00 2001
From: Christian Kellermann <ckeen@pestilenz.org>
Date: Fri, 7 Jan 2011 18:06:13 +0100
Subject: [PATCH] Add condition->list procedure

This addition to library.scm allows programs to convert, inspect or
print condition objects independently from chicken's internal
structures.

Example:
(condition->list
  (make-property-condition 'exn
			   'message "foo"
			   'arguments '("bar")
			   'location 'test))
=> ((exn (location test) (arguments ("bar")) (message "foo")))

Tests for this behaviour are added to the test script.
---
 library.scm               |   16 ++++++++++++++++
 tests/condition-tests.scm |   32 ++++++++++++++++++++++++++++++++
 tests/runtests.sh         |    3 +++
 3 files changed, 51 insertions(+), 0 deletions(-)
 create mode 100644 tests/condition-tests.scm

diff --git a/library.scm b/library.scm
index 3c1b7d5..3498d6d 100644
    a b EOF 
    38963896
    38973897(define (condition? x) (##sys#structure? x 'condition))
    38983898
     3899(define (condition->list x)
     3900  (or (condition? x)
     3901      (##sys#signal-hook
     3902       #:type-error 'condition->list
     3903       "argument is not a condition object" x))
     3904  (map
     3905   (lambda (k)
     3906     (cons k (let loop ((props (##sys#slot x 2))
     3907                        (res '()))
     3908               (cond ((null? props)
     3909                      res)
     3910                     ((eq? k (caar props))
     3911                      (loop (cddr props) (cons (list (cdar props) (cadr props)) res)))
     3912                     (else (loop (cddr props) res))))))
     3913   (##sys#slot x 1)))
     3914
    38993915(define (condition-predicate kind)
    39003916  (lambda (c)
    39013917    (##sys#check-structure c 'condition)

  • new file tests/condition-tests.scm 

    diff --git a/tests/condition-tests.scm b/tests/condition-tests.scm
new file mode 100644
index 0000000..e74ba36
    - +  
     1
     2(define condition1 (make-property-condition 'exn 'message "foo" 'arguments '("bar") 'location 'test))
     3(define condition2 (make-property-condition 'sam 'age 23 'partner "max"))
     4(define condition3 (make-composite-condition (make-property-condition 'exn 'message "foo" 'arguments '("bar") 'location 'test)(make-property-condition 'sam 'age 23 'partner "max")))
     5
     6(define conditions (list condition1 condition2 condition3))
     7
     8; testing type predicate
     9(for-each (lambda (c) (assert (condition? c))) conditions)
     10
     11;testing slot allocations
     12; slot 1 should be the kind key
     13; slot 2 should hold all properties
     14
     15(assert (and (equal? '(exn) (##sys#slot condition1 1))
     16             (equal? '(sam) (##sys#slot condition2 1))
     17             (equal? '(exn sam) (##sys#slot condition3 1))))
     18
     19(assert (equal? (##sys#slot condition1 2)
     20                '((exn . message) "foo" (exn . arguments) ("bar") (exn . location) test)))
     21
     22(assert (equal? (##sys#slot condition3 2)
     23                '((exn . message) "foo" (exn . arguments) ("bar") (exn . location) test
     24                  (sam . age) 23 (sam . partner) "max")))
     25
     26;testing condition conversion
     27
     28(assert (equal? (condition->list condition1)
     29                '((exn (location test) (arguments ("bar")) (message "foo")))))
     30
     31(assert (equal? (condition->list condition3)
     32                '((exn (location test) (arguments ("bar")) (message "foo")) (sam (partner "max") (age 23)))))

  • tests/runtests.sh 

    diff --git a/tests/runtests.sh b/tests/runtests.sh
index 61a8c61..a44804e 100644
    a b $compile fixnum-tests.scm 
    221221echo "======================================== srfi-4 tests ..."
    222222$interpret -s srfi-4-tests.scm
    223223
     224echo "======================================== condition tests ..."
     225$interpret -s condition-tests.scm
     226
    224227echo "======================================== srfi-18 tests ..."
    225228$interpret -s simple-thread-test.scm
    226229$interpret -s mutex-test.scm