scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added SRFI-34/35: conditions and exception handling

This commit is contained in:
Eric Knauel 2003-12-02 09:48:46 +00:00
parent df3ae1e892
commit eeb9ccd78a
6 changed files with 293 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
s48/exceptions/AUTHORS Normal file
View File

@ -0,0 +1,2 @@
Richard Kelsey
Michael Sperber

1
s48/exceptions/BLURB Normal file
View File

@ -0,0 +1 @@
An exception and condition system for Scheme

24
s48/exceptions/interfaces.scm Normal file
View File

@ -0,0 +1,24 @@
(define-interface srfi-34-interface
(export
raise
with-exception-handler
with-exception-handlers
(guard :syntax)))
(define-interface srfi-35-interface
(export
make-condition-type
condition-type?
make-condition
condition?
condition-has-type?
condition-ref
make-compound-condition
extract-condition
(define-condition-type :syntax)
(condition :syntax)
&condition
&message message-condition? condition-message
&serious serious-condition?
&error error?))

11
s48/exceptions/packages.scm Normal file
View File

@ -0,0 +1,11 @@
(define-structure srfi-34 srfi-34-interface
(open scheme
signals)
(files srfi-34))
(define-structure srfi-35 srfi-35-interface
(open scheme
signals
srfi-1
srfi-9)
(files srfi-35))

78
s48/exceptions/srfi-34.scm Normal file
View File

@ -0,0 +1,78 @@
(define *current-exception-handlers*
(list (lambda (condition)
(error "*current-exception-handler*" "unhandled exception" condition))))
(define (with-exception-handlers new-handlers thunk)
(let ((previous-handlers *current-exception-handlers*))
(dynamic-wind
(lambda ()
(set! *current-exception-handlers* new-handlers))
thunk
(lambda ()
(set! *current-exception-handlers* previous-handlers)))))
(define (with-exception-handler handler thunk)
(with-exception-handlers (cons handler *current-exception-handlers*)
thunk))
(define (raise obj)
(let ((handlers *current-exception-handlers*))
(with-exception-handlers (cdr handlers)
(lambda ()
((car handlers) obj)
(error "handler returned"
(car handlers)
obj)))))
(define-syntax guard
(syntax-rules ()
((guard (var clause ...) e1 e2 ...)
((call-with-current-continuation
(lambda (guard-k)
(with-exception-handler
(lambda (condition)
((call-with-current-continuation
(lambda (handler-k)
(guard-k
(lambda ()
(let ((var condition)) ; clauses may SET! var
(guard-aux (handler-k (lambda ()
(raise condition)))
clause ...))))))))
(lambda ()
(call-with-values
(lambda () e1 e2 ...)
(lambda args
(guard-k (lambda ()
(apply values args)))))))))))))
(define-syntax guard-aux
(syntax-rules (else =>)
((guard-aux reraise (else result1 result2 ...))
(begin result1 result2 ...))
((guard-aux reraise (test => result))
(let ((temp test))
(if temp
(result temp)
reraise)))
((guard-aux reraise (test => result) clause1 clause2 ...)
(let ((temp test))
(if temp
(result temp)
(guard-aux reraise clause1 clause2 ...))))
((guard-aux reraise (test))
test)
((guard-aux reraise (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(guard-aux reraise clause1 clause2 ...))))
((guard-aux reraise (test result1 result2 ...))
(if test
(begin result1 result2 ...)
reraise))
((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...)))))

177
s48/exceptions/srfi-35.scm Normal file
View File

@ -0,0 +1,177 @@
(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?)