218 lines
8.6 KiB
Scheme
218 lines
8.6 KiB
Scheme
#!r6rs
|
|
(library (srfi :35 conditions)
|
|
(export make-condition-type condition-type? condition-has-type?
|
|
condition-ref make-compound-condition
|
|
extract-condition define-condition-type
|
|
&condition make-condition condition? condition
|
|
&serious serious-condition?
|
|
&error error?
|
|
&message message-condition? condition-message)
|
|
(import
|
|
(except (rnrs) define-condition-type condition
|
|
&condition condition?
|
|
&serious serious-condition?
|
|
&error error?
|
|
&message message-condition? condition-message
|
|
define-record-type
|
|
error)
|
|
(only (srfi :1) lset= lset-intersection lset-difference any)
|
|
(srfi :9)
|
|
(srfi :23))
|
|
|
|
;; reference implementation from srfi 35: overlaps some of r6rs conditions
|
|
|
|
;; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved.
|
|
;;
|
|
;; Permission is hereby granted, free of charge, to any person obtaining a
|
|
;; copy of this software and associated documentation files (the "Software"),
|
|
;; to deal in the Software without restriction, including without limitation
|
|
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
|
;; and/or sell copies of the Software, and to permit persons to whom the
|
|
;; Software is furnished to do so, subject to the following conditions:
|
|
;;
|
|
;; The above copyright notice and this permission notice shall be included in
|
|
;; all copies or substantial portions of the Software.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
|
;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
|
;; DEALINGS IN THE SOFTWARE.
|
|
|
|
(define-record-type :condition-type
|
|
(really-make-condition-type name supertype fields all-fields)
|
|
condition-type?
|
|
(name condition-type-name)
|
|
(supertype condition-type-supertype)
|
|
(fields condition-type-fields)
|
|
(all-fields condition-type-all-fields))
|
|
|
|
(define (make-condition-type name supertype fields)
|
|
(if (not (symbol? name))
|
|
(error "make-condition-type: name is not a symbol"
|
|
name))
|
|
(if (not (condition-type? supertype))
|
|
(error "make-condition-type: supertype is not a condition type"
|
|
supertype))
|
|
(if (not
|
|
(null? (lset-intersection eq?
|
|
(condition-type-all-fields supertype)
|
|
fields)))
|
|
(error "duplicate field name" ))
|
|
(really-make-condition-type name
|
|
supertype
|
|
fields
|
|
(append (condition-type-all-fields supertype)
|
|
fields)))
|
|
|
|
(define-syntax define-condition-type
|
|
(syntax-rules ()
|
|
((define-condition-type ?name ?supertype ?predicate
|
|
(?field1 ?accessor1) ...)
|
|
(begin
|
|
(define ?name
|
|
(make-condition-type '?name
|
|
?supertype
|
|
'(?field1 ...)))
|
|
(define (?predicate thing)
|
|
(and (condition? thing)
|
|
(condition-has-type? thing ?name)))
|
|
(define (?accessor1 condition)
|
|
(condition-ref (extract-condition condition ?name)
|
|
'?field1))
|
|
...))))
|
|
|
|
(define (condition-subtype? subtype supertype)
|
|
(let recur ((subtype subtype))
|
|
(cond ((not subtype) #f)
|
|
((eq? subtype supertype) #t)
|
|
(else
|
|
(recur (condition-type-supertype subtype))))))
|
|
|
|
(define (condition-type-field-supertype condition-type field)
|
|
(let loop ((condition-type condition-type))
|
|
(cond ((not condition-type) #f)
|
|
((memq field (condition-type-fields condition-type))
|
|
condition-type)
|
|
(else
|
|
(loop (condition-type-supertype condition-type))))))
|
|
|
|
; The type-field-alist is of the form
|
|
; ((<type> (<field-name> . <value>) ...) ...)
|
|
(define-record-type :condition
|
|
(really-make-condition type-field-alist)
|
|
condition?
|
|
(type-field-alist condition-type-field-alist))
|
|
|
|
(define (make-condition type . field-plist)
|
|
(let ((alist (let label ((plist field-plist))
|
|
(if (null? plist)
|
|
'()
|
|
(cons (cons (car plist)
|
|
(cadr plist))
|
|
(label (cddr plist)))))))
|
|
(if (not (lset= eq?
|
|
(condition-type-all-fields type)
|
|
(map car alist)))
|
|
(error "condition fields don't match condition type"))
|
|
(really-make-condition (list (cons type alist)))))
|
|
|
|
(define (condition-has-type? condition type)
|
|
(any (lambda (has-type)
|
|
(condition-subtype? has-type type))
|
|
(condition-types condition)))
|
|
|
|
(define (condition-ref condition field)
|
|
(type-field-alist-ref (condition-type-field-alist condition)
|
|
field))
|
|
|
|
(define (type-field-alist-ref type-field-alist field)
|
|
(let loop ((type-field-alist type-field-alist))
|
|
(cond ((null? type-field-alist)
|
|
(error "type-field-alist-ref: field not found"
|
|
type-field-alist field))
|
|
((assq field (cdr (car type-field-alist)))
|
|
=> cdr)
|
|
(else
|
|
(loop (cdr type-field-alist))))))
|
|
|
|
(define (make-compound-condition condition-1 . conditions)
|
|
(really-make-condition
|
|
(apply append (map condition-type-field-alist
|
|
(cons condition-1 conditions)))))
|
|
|
|
(define (extract-condition condition type)
|
|
(let ((entry (find (lambda (entry)
|
|
(condition-subtype? (car entry) type))
|
|
(condition-type-field-alist condition))))
|
|
(if (not entry)
|
|
(error "extract-condition: invalid condition type"
|
|
condition type))
|
|
(really-make-condition
|
|
(list (cons type
|
|
(map (lambda (field)
|
|
(assq field (cdr entry)))
|
|
(condition-type-all-fields type)))))))
|
|
|
|
(define-syntax condition
|
|
(syntax-rules ()
|
|
((condition (?type1 (?field1 ?value1) ...) ...)
|
|
(type-field-alist->condition
|
|
(list
|
|
(cons ?type1
|
|
(list (cons '?field1 ?value1) ...))
|
|
...)))))
|
|
|
|
(define (type-field-alist->condition type-field-alist)
|
|
(really-make-condition
|
|
(map (lambda (entry)
|
|
(cons (car entry)
|
|
(map (lambda (field)
|
|
(or (assq field (cdr entry))
|
|
(cons field
|
|
(type-field-alist-ref type-field-alist field))))
|
|
(condition-type-all-fields (car entry)))))
|
|
type-field-alist)))
|
|
|
|
(define (condition-types condition)
|
|
(map car (condition-type-field-alist condition)))
|
|
|
|
(define (check-condition-type-field-alist the-type-field-alist)
|
|
(let loop ((type-field-alist the-type-field-alist))
|
|
(if (not (null? type-field-alist))
|
|
(let* ((entry (car type-field-alist))
|
|
(type (car entry))
|
|
(field-alist (cdr entry))
|
|
(fields (map car field-alist))
|
|
(all-fields (condition-type-all-fields type)))
|
|
(for-each (lambda (missing-field)
|
|
(let ((supertype
|
|
(condition-type-field-supertype type missing-field)))
|
|
(if (not
|
|
(any (lambda (entry)
|
|
(let ((type (car entry)))
|
|
(condition-subtype? type supertype)))
|
|
the-type-field-alist))
|
|
(error "missing field in condition construction"
|
|
type
|
|
missing-field))))
|
|
(lset-difference eq? all-fields fields))
|
|
(loop (cdr type-field-alist))))))
|
|
|
|
(define &condition (really-make-condition-type '&condition
|
|
#f
|
|
'()
|
|
'()))
|
|
|
|
(define-condition-type &message &condition
|
|
message-condition?
|
|
(message condition-message))
|
|
|
|
(define-condition-type &serious &condition
|
|
serious-condition?)
|
|
|
|
(define-condition-type &error &serious
|
|
error?))
|