From bbfecd12e1602a87a782fa095842a2fd52e935f0 Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Wed, 11 Apr 2007 14:06:01 +0000 Subject: [PATCH] SRFI 35 added svn: r5924 --- collects/srfi/34.ss | 3 +- collects/srfi/34/exception.ss | 3 +- collects/srfi/35.ss | 4 + collects/srfi/35/condition.ss | 194 ++++++++++++++++++++++++++++++ collects/tests/srfi/load-srfis.ss | 4 +- 5 files changed, 203 insertions(+), 5 deletions(-) create mode 100644 collects/srfi/35.ss create mode 100644 collects/srfi/35/condition.ss diff --git a/collects/srfi/34.ss b/collects/srfi/34.ss index c8913ed805..5b79d5a1d3 100644 --- a/collects/srfi/34.ss +++ b/collects/srfi/34.ss @@ -1,5 +1,4 @@ ;; module loader for SRFI-34 (module |34| mzscheme (require (lib "exception.ss" "srfi" "34")) - (provide (all-from (lib "exception.ss" "srfi" "34")) - raise)) + (provide (all-from (lib "exception.ss" "srfi" "34")))) diff --git a/collects/srfi/34/exception.ss b/collects/srfi/34/exception.ss index ba620f4414..eef927a15e 100644 --- a/collects/srfi/34/exception.ss +++ b/collects/srfi/34/exception.ss @@ -4,7 +4,8 @@ (module exception mzscheme (provide with-exception-handler - guard) + guard + raise) (define-syntax with-exception-handler (syntax-rules () diff --git a/collects/srfi/35.ss b/collects/srfi/35.ss new file mode 100644 index 0000000000..5b11274805 --- /dev/null +++ b/collects/srfi/35.ss @@ -0,0 +1,4 @@ +;; module loader for SRFI-35 +(module |35| mzscheme + (require (lib "condition.ss" "srfi" "35")) + (provide (all-from (lib "condition.ss" "srfi" "35")))) diff --git a/collects/srfi/35/condition.ss b/collects/srfi/35/condition.ss new file mode 100644 index 0000000000..0437d9efab --- /dev/null +++ b/collects/srfi/35/condition.ss @@ -0,0 +1,194 @@ +(module condition mzscheme + + (require (lib "list.ss" "srfi" "1") + (lib "9.ss" "srfi")) + + (provide make-condition-type + condition-type? + make-condition + condition? + condition-has-type? + condition-ref + make-compound-condition + extract-condition + define-condition-type + condition + &condition + &message + &serious + &error) + + (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?)) \ No newline at end of file diff --git a/collects/tests/srfi/load-srfis.ss b/collects/tests/srfi/load-srfis.ss index 21efcdcd45..7917d4bbca 100644 --- a/collects/tests/srfi/load-srfis.ss +++ b/collects/tests/srfi/load-srfis.ss @@ -21,6 +21,7 @@ (require (lib "31.ss" "srfi")) (require (lib "32.ss" "srfi")) (require (lib "34.ss" "srfi")) +(require (lib "35.ss" "srfi")) (require (lib "40.ss" "srfi")) (require (lib "42.ss" "srfi")) (require (lib "43.ss" "srfi")) @@ -30,7 +31,6 @@ (require (lib "59.ss" "srfi")) (require (lib "60.ss" "srfi")) (require (lib "61.ss" "srfi")) -(require (lib "63.ss" "srfi")) (require (lib "66.ss" "srfi")) (require (lib "67.ss" "srfi")) (require (lib "69.ss" "srfi")) @@ -58,6 +58,7 @@ (require (lib "rec.ss" "srfi" "31")) (require (lib "sort.scm" "srfi" "32")) (require (lib "exception.ss" "srfi" "34")) +(require (lib "condition.ss" "srfi" "35")) (require (lib "stream.ss" "srfi" "40")) (require (lib "comprehensions.ss" "srfi" "42")) (require (lib "vector-lib.ss" "srfi" "43")) @@ -67,7 +68,6 @@ (require (lib "vicinity.ss" "srfi" "59")) (require (lib "60.ss" "srfi" "60")) (require (lib "cond.ss" "srfi" "61")) -(require (lib "63.ss" "srfi" "63")) (require (lib "66.ss" "srfi" "66")) (require (lib "compare.ss" "srfi" "67")) (require (lib "hash.ss" "srfi" "69"))