~ chicken-core (chicken-5) 5559d61913c2828eb53ae3f6653ec5162bf427a0

commit 5559d61913c2828eb53ae3f6653ec5162bf427a0
Author:     Christian Kellermann <ckeen@pestilenz.org>
AuthorDate: Fri Jan 7 18:06:13 2011 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jan 19 05:26:18 2011 -0500

    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.

diff --git a/library.scm b/library.scm
index ec341757..8640c606 100644
--- a/library.scm
+++ b/library.scm
@@ -3896,6 +3896,22 @@ EOF
 
 (define (condition? x) (##sys#structure? x 'condition))
 
+(define (condition->list x)
+  (or (condition? x)
+      (##sys#signal-hook
+       #:type-error 'condition->list
+       "argument is not a condition object" x))
+  (map
+   (lambda (k)
+     (cons k (let loop ((props (##sys#slot x 2))
+			(res '()))
+	       (cond ((null? props)
+		      res)
+		     ((eq? k (caar props))
+		      (loop (cddr props) (cons (list (cdar props) (cadr props)) res)))
+		     (else (loop (cddr props) res))))))
+   (##sys#slot x 1)))
+
 (define (condition-predicate kind)
   (lambda (c) 
     (##sys#check-structure c 'condition)
diff --git a/tests/condition-tests.scm b/tests/condition-tests.scm
new file mode 100644
index 00000000..e74ba36c
--- /dev/null
+++ b/tests/condition-tests.scm
@@ -0,0 +1,32 @@
+
+(define condition1 (make-property-condition 'exn 'message "foo" 'arguments '("bar") 'location 'test))
+(define condition2 (make-property-condition 'sam 'age 23 'partner "max"))
+(define condition3 (make-composite-condition (make-property-condition 'exn 'message "foo" 'arguments '("bar") 'location 'test)(make-property-condition 'sam 'age 23 'partner "max")))
+
+(define conditions (list condition1 condition2 condition3))
+
+; testing type predicate
+(for-each (lambda (c) (assert (condition? c))) conditions)
+
+;testing slot allocations
+; slot 1 should be the kind key
+; slot 2 should hold all properties
+
+(assert (and (equal? '(exn) (##sys#slot condition1 1))
+	     (equal? '(sam) (##sys#slot condition2 1))
+	     (equal? '(exn sam) (##sys#slot condition3 1))))
+
+(assert (equal? (##sys#slot condition1 2)
+		'((exn . message) "foo" (exn . arguments) ("bar") (exn . location) test)))
+
+(assert (equal? (##sys#slot condition3 2)
+		'((exn . message) "foo" (exn . arguments) ("bar") (exn . location) test
+		  (sam . age) 23 (sam . partner) "max")))
+
+;testing condition conversion
+
+(assert (equal? (condition->list condition1)
+		'((exn (location test) (arguments ("bar")) (message "foo")))))
+
+(assert (equal? (condition->list condition3)
+		'((exn (location test) (arguments ("bar")) (message "foo")) (sam (partner "max") (age 23)))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 09f95a05..7b670a88 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -221,6 +221,9 @@ $compile fixnum-tests.scm
 echo "======================================== srfi-4 tests ..."
 $interpret -s srfi-4-tests.scm
 
+echo "======================================== condition tests ..."
+$interpret -s condition-tests.scm
+
 echo "======================================== srfi-18 tests ..."
 $interpret -s simple-thread-test.scm
 $interpret -s mutex-test.scm