From b768f8cf4c3d45d5296b37d69d2cb2d5f6a59524 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sat, 20 May 2017 14:25:54 +0200
Subject: [PATCH] Add a more convenient way of constructing condition objects

This "condition" constructor is inspired by Kon Lovett's
"make-condition+" constructor from the condition-utils egg.

This also adds a helper procedure for converting plist-style condition
property lists to the internal structure of condition properties by
consing the kind onto the property, followed by the value.  This also
is used in make-property-condition, which now gives a better error
message when the property list argument isn't a list with an even
element count.
---
 chicken.condition.import.scm |  1 +
 library.scm                  | 32 +++++++++++++++++++++++++-------
 types.db                     |  1 +
 3 files changed, 27 insertions(+), 7 deletions(-)

diff --git a/chicken.condition.import.scm b/chicken.condition.import.scm
index 00fc0c9..effe068 100644
--- a/chicken.condition.import.scm
+++ b/chicken.condition.import.scm
@@ -34,6 +34,7 @@
    (with-exception-handler . chicken.condition#with-exception-handler)
    (make-property-condition . chicken.condition#make-property-condition)
    (make-composite-condition . chicken.condition#make-composite-condition)
+   (condition . chicken.condition#condition)
    (condition? . chicken.condition#condition?)
    (condition->list . chicken.condition#condition->list)
    (condition-predicate . chicken.condition#condition-predicate)
diff --git a/library.scm b/library.scm
index d7a0580..5eb43dd 100644
--- a/library.scm
+++ b/library.scm
@@ -4455,9 +4455,9 @@ EOF
      ;; [syntax] condition-case handle-exceptions
 
      ;; Condition object manipulation
-     make-property-condition make-composite-condition condition?
-     condition->list condition-predicate condition-property-accessor
-     get-condition-property)
+     make-property-condition make-composite-condition
+     condition condition? condition->list condition-predicate
+     condition-property-accessor get-condition-property)
 
 (import scheme)
 (import chicken.fixnum)
@@ -4706,13 +4706,22 @@ EOF
 
 ;;; Condition object manipulation
 
+(define (prop-list->kind-prefixed-prop-list loc kind plist)
+  (let loop ((props plist))
+    (cond
+     ((null? props) '())
+     ((or (not (pair? props)) (not (pair? (cdr props))))
+      (##sys#signal-hook
+       #:type-error loc "argument is not an even property list" plist))
+     (else (cons (cons kind (car props))
+		 (cons (cadr props)
+		       (loop (cddr props)))) ) ) ))
+
 (define (make-property-condition kind . props)
   (##sys#make-structure
    'condition (list kind)
-   (let loop ((props props))
-     (if (null? props)
-	 '()
-	 (cons (cons kind (car props)) (cons (cadr props) (loop (cddr props)))) ) ) ) )
+   (prop-list->kind-prefixed-prop-list
+    'make-property-condition kind props) ) )
 
 (define (make-composite-condition c1 . conds)
   (let ([conds (cons c1 conds)])
@@ -4722,6 +4731,15 @@ EOF
      (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
      (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) )
 
+(define (condition arg1 . args)
+  (let* ((args (cons arg1 args))
+	 (keys (apply ##sys#append
+		      (map (lambda (c)
+			     (prop-list->kind-prefixed-prop-list
+			      'condition (car c) (cdr c)))
+			     args))) )
+    (##sys#make-structure 'condition (map car args) keys)))
+
 (define (condition? x) (##sys#structure? x 'condition))
 
 (define (condition->list x)
diff --git a/types.db b/types.db
index 7e30466..bafa785 100644
--- a/types.db
+++ b/types.db
@@ -948,6 +948,7 @@
 ;; condition
 
 (chicken.condition#abort (procedure chicken.condition#abort (*) noreturn))
+(chicken.condition#condition (#(procedure #:clean #:enforce) chicken.condition#condition (list #!rest list) (struct condition)))
 (chicken.condition#condition? (#(procedure #:pure #:predicate (struct condition)) chicken.condition#condition? (*) boolean))
 (chicken.condition#condition->list (#(procedure #:clean #:enforce) chicken.condition#condition->list ((struct condition)) (list-of (pair symbol *))))
 (chicken.condition#condition-predicate (#(procedure #:clean #:enforce) chicken.condition#condition-predicate (symbol) (procedure ((struct condition)) boolean)))
-- 
2.1.4