added SRFI-34/35: conditions and exception handling

s48/exceptions/AUTHORS

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

s48/exceptions/BLURB

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

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?))
+

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))

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 ...)))))
+

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
+; ((<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?)