On Fri, May 19, 2017 at 01:10:03PM +1200, Evan Hanson wrote: > Hi Peter, > > On 2017-05-07 21:45, Peter Bex wrote: > > The core-library-reorganization page has "(chicken condition)" under > > "undecided", but I think it's fine the way it is. The attached patches > > add this module. > > These have been applied. Excellent work, it looks like these were tricky > changes.
Attached is a patch to introduce the more convenient constructor for
condition objects we talked about on IRC. It's heavily inspired by
Kon Lovett's make-condition+ from his condition-utils egg.
It can be used like this:
(signal (condition '(exn location "foo" message "hi") '(file bar 1)))
which is equivalent to:
(signal (make-composite-condition
(make-property-condition 'exn 'location 1 'message "hi")
(make-property-condition 'file 'bar 2)))
It also improves make-property-condition by giving a better error
message when you pass in an invalid list length, something like
(make-property-condition 'exn 'location) would give an error message
like "(cadr) bad argument type: ()", which doesn't really help.
Cheers,
Peter
From b768f8cf4c3d45d5296b37d69d2cb2d5f6a59524 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
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
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
