~ chicken-core (chicken-5) d6e8928745b3d9824b5e31dc1d0130a40b3632fb

commit d6e8928745b3d9824b5e31dc1d0130a40b3632fb
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat May 20 14:25:54 2017 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sat May 27 11:25:26 2017 +1200

    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.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/chicken.condition.import.scm b/chicken.condition.import.scm
index 00fc0c95..effe0685 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 e8afbc39..4007fe37 100644
--- a/library.scm
+++ b/library.scm
@@ -4449,9 +4449,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)
@@ -4700,13 +4700,21 @@ 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)])
@@ -4716,6 +4724,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 f9fe6654..604c2382 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)))