From eeb9ccd78a030fa1496ad145f1dab30abc51682a Mon Sep 17 00:00:00 2001 From: Eric Knauel Date: Tue, 2 Dec 2003 09:48:46 +0000 Subject: [PATCH] added SRFI-34/35: conditions and exception handling --- s48/exceptions/AUTHORS | 2 + s48/exceptions/BLURB | 1 + s48/exceptions/interfaces.scm | 24 +++++ s48/exceptions/packages.scm | 11 +++ s48/exceptions/srfi-34.scm | 78 +++++++++++++++ s48/exceptions/srfi-35.scm | 177 ++++++++++++++++++++++++++++++++++ 6 files changed, 293 insertions(+) create mode 100644 s48/exceptions/AUTHORS create mode 100644 s48/exceptions/BLURB create mode 100644 s48/exceptions/interfaces.scm create mode 100644 s48/exceptions/packages.scm create mode 100644 s48/exceptions/srfi-34.scm create mode 100644 s48/exceptions/srfi-35.scm diff --git a/s48/exceptions/AUTHORS b/s48/exceptions/AUTHORS new file mode 100644 index 0000000..16871fa --- /dev/null +++ b/s48/exceptions/AUTHORS @@ -0,0 +1,2 @@ +Richard Kelsey +Michael Sperber \ No newline at end of file diff --git a/s48/exceptions/BLURB b/s48/exceptions/BLURB new file mode 100644 index 0000000..18b92b5 --- /dev/null +++ b/s48/exceptions/BLURB @@ -0,0 +1 @@ +An exception and condition system for Scheme \ No newline at end of file diff --git a/s48/exceptions/interfaces.scm b/s48/exceptions/interfaces.scm new file mode 100644 index 0000000..d5322e2 --- /dev/null +++ b/s48/exceptions/interfaces.scm @@ -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?)) + diff --git a/s48/exceptions/packages.scm b/s48/exceptions/packages.scm new file mode 100644 index 0000000..650635b --- /dev/null +++ b/s48/exceptions/packages.scm @@ -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)) diff --git a/s48/exceptions/srfi-34.scm b/s48/exceptions/srfi-34.scm new file mode 100644 index 0000000..b3e5944 --- /dev/null +++ b/s48/exceptions/srfi-34.scm @@ -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 ...))))) + diff --git a/s48/exceptions/srfi-35.scm b/s48/exceptions/srfi-35.scm new file mode 100644 index 0000000..2ce035e --- /dev/null +++ b/s48/exceptions/srfi-35.scm @@ -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 +; (( ( . ) ...) ...) +(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?)