diff --git a/lib/srfi/35.sld b/lib/srfi/35.sld new file mode 100644 index 00000000..13c13c9a --- /dev/null +++ b/lib/srfi/35.sld @@ -0,0 +1,24 @@ +(define-library (srfi 35) + (import (srfi 35 internal)) + (export make-condition-type + condition-type? + make-condition + condition? + condition-has-type? + condition-ref + make-compound-condition + extract-condition + define-condition-type + condition + + &condition + + &message + message-condition? + condition-message + + &serious + serious-condition? + + &error + error?)) diff --git a/lib/srfi/35/internal.scm b/lib/srfi/35/internal.scm new file mode 100644 index 00000000..b8b94f6f --- /dev/null +++ b/lib/srfi/35/internal.scm @@ -0,0 +1,249 @@ +(define-record-type Simple-Condition + (make-simple-condition) + simple-condition?) + +(define-record-type Compound-Condition + (%make-compound-condition components) + compound-condition? + (components compound-condition-components)) + +(define (make-condition-type id parent field-names) + (make-rtd id + (list->vector + (map + (lambda (field-name) + (list 'immutable field-name)) + field-names)) + parent)) + +(define (condition? obj) + (or (simple-condition? obj) + (compound-condition? obj))) + +(define (condition-type? obj) + (condition-subtype? obj Simple-Condition)) + +(define (condition-subtype? maybe-child-ct maybe-parent-ct) + (and (rtd? maybe-child-ct) + (or (eqv? maybe-child-ct maybe-parent-ct) + (condition-subtype? (rtd-parent maybe-child-ct) + maybe-parent-ct)))) + +(define (condition-type-ancestors ct) + (unfold (lambda (a) (not (condition-type? a))) + (lambda (a) a) + (lambda (a) (rtd-parent a)) + ct)) + +(define (condition-type-common-ancestor ct_1 ct_2) + (let ((ct_1-as (condition-type-ancestors ct_1)) + (ct_2-as (condition-type-ancestors ct_2))) + (find (lambda (a) + (memv a ct_2-as)) + ct_1-as))) + +(define (make-condition ct . plist) + (define *undef* (cons '*undef* '())) + (let* ((field-names (rtd-all-field-names ct)) + (field-values (make-vector (vector-length field-names) *undef*))) + (let loop ((property plist)) + (if (null? property) + (cond ((vector-any (lambda (name value) + (and (eq? value *undef*) name)) + field-names + field-values) + => (lambda (undef-field-name) + (error "make-condition: value not given for field" + undef-field-name + ct))) + (else + (apply (rtd-constructor ct) (vector->list field-values)))) + (let ((idx (vector-index (lambda (x) (eq? x (car property))) + field-names))) + (if idx + (begin + (vector-set! field-values idx (cadr property)) + (loop (cddr property))) + (error "make-condition: unknown field" (car property)))))))) + +(define (make-compound-condition . cs) + (if (= (length cs) 1) + (car cs) + ;; SRFI 35 requires at least one component, but R6RS doesn’t; + ;; defer to R6RS’s less strict error checking (!) + (%make-compound-condition + (append-map + (lambda (c) + (if (simple-condition? c) + (list c) + (compound-condition-components c))) + cs)))) + +(define (condition-has-type? c ct) + (if (simple-condition? c) + (is-a? c ct) + (any + (lambda (comp) (condition-has-type? comp ct)) + (compound-condition-components c)))) + +(define (condition-ref c field-name) + (if (simple-condition? c) + ((rtd-accessor (record-rtd c) field-name) c) + (condition-ref + (find + (lambda (comp) + (find field-name + (vector->list + (rtd-all-field-names (record-rtd c))))) + (compound-condition-components c)) + field-name))) + +(define (simple-conditions c) + (if (simple-condition? c) + (list c) + (compound-condition-components c))) + +(define (extract-condition c ct) + (if (and (simple-condition? c) + (condition-has-type? c ct)) + c + (find + (lambda (comp) + (condition-has-type? comp ct)) + (compound-condition-components ct)))) + +(define (condition-predicate ct) + (lambda (obj) + (and (condition? obj) + (condition-has-type? obj ct)))) +(define (condition-accessor ct proc) + (lambda (c) + (cond ((and (simple-condition? c) + (condition-has-type? c ct)) + (proc c)) + ((find (lambda (comp) (condition-has-type? comp ct)) + (compound-condition-components c)) + => (lambda (comp) + (proc comp))) + (else (error "condition-accessor: condition does not have the right type" + c ct))))) + +(define-syntax define-condition-type/constructor + (syntax-rules () + ((_ name parent constructor predicate + (field-name field-accessor) ...) + (begin + (define ct (make-condition-type 'name + parent + '(field-name ...))) + (define name ct) + (define constructor (rtd-constructor ct)) + (define predicate (condition-predicate ct)) + (define field-accessor + (condition-accessor ct + (rtd-accessor ct 'field-name))) ...)))) + +(define-syntax define-condition-type + (syntax-rules () + ((_ name parent predicate (field-name field-accessor) ...) + (define-condition-type/constructor + name parent blah-ignored predicate + (field-name field-accessor) ...)))) + +(define (%condition . specs) + (define (find-common-field-spec ct name) + (let loop ((more-specs specs)) + (if (null? more-specs) + #f + (let* ((other-ct (caar more-specs)) + (field-specs (cdar more-specs)) + (a (condition-type-common-ancestor ct other-ct))) + (cond ((and (vector-index + (lambda (n) + (eq? n name)) + (rtd-all-field-names a)) + (assq name field-specs))) + (else (loop (cdr more-specs)))))))) + (let loop ((more-specs specs) + (components '())) + (if (null? more-specs) + (apply make-compound-condition (reverse components)) + (let* ((this-spec (car more-specs)) + (ct (car this-spec)) + (field-specs (cdr this-spec)) + (field-names (rtd-all-field-names ct)) + (field-values + (vector-map + (lambda (field-name) + (cond ((assq field-name field-specs) => cdr) + ((find-common-field-spec ct field-name) => cdr) + (else + (error "condition: value not given for field" + field-name + ct)))) + field-names))) + (loop + (cdr more-specs) + (cons + (apply (rtd-constructor ct) (vector->list field-values)) + components)))))) +(define-syntax condition + (syntax-rules () + ((_ (ct (field-name field-value) ...) ...) + (%condition (list ct (cons 'field-name field-value) ...) ...)))) + +(define &condition Simple-Condition) + +(define-condition-type/constructor &message &condition + make-message-condition message-condition? + (message condition-message)) + +(define-condition-type/constructor &serious &condition + make-serious-condition serious-condition?) + +(define-condition-type/constructor &error &serious + make-error error?) + +;; (chibi repl) support +(define-method (repl-print-exception (exn condition?) (out output-port?)) + (define components (simple-conditions exn)) + (define n-components (length components)) + (display "CONDITION: " out) + (display n-components out) + (display " component" out) + (if (not (= n-components 1)) (display "s" out)) + (display "\n" out) + (for-each + (lambda (component idx) + (define component-type (record-rtd component)) + (display " " out) + (display idx out) + (display ". " out) + (display (rtd-name component-type) out) + (display "\n" out) + (let loop ((as (reverse + (condition-type-ancestors component-type))) + (idx 0)) + (if (not (null? as)) + (let ((a (car as))) + (let a-loop ((fields (vector->list (rtd-field-names a))) + (idx idx)) + (if (null? fields) + (loop (cdr as) idx) + (begin + (display " " out) + (display (if (pair? (car fields)) + (car (cdar fields)) + (car fields)) + out) + (if (not (eqv? a component-type)) + (begin + (display " (" out) + (display (rtd-name a) out) + (display ")" out))) + (display ": " out) + (write (slot-ref component-type component idx) out) + (display "\n" out) + (a-loop (cdr fields) (+ idx 1))))))))) + components + (iota n-components 1))) diff --git a/lib/srfi/35/internal.sld b/lib/srfi/35/internal.sld new file mode 100644 index 00000000..0bc944a6 --- /dev/null +++ b/lib/srfi/35/internal.sld @@ -0,0 +1,48 @@ +(define-library (srfi 35 internal) + (import (except (scheme base) + define-record-type + ;; exclude (srfi 1 immutable) duplicate imports: + map cons list append reverse) + (scheme write) + (only (chibi) + slot-ref + is-a?) + (only (chibi repl) repl-print-exception) + (only (chibi generic) define-method) + ;; don’t let people go messing with a compound condition + ;; components list: + (srfi 1 immutable) + (srfi 99) + (srfi 133)) + (export make-condition-type + condition? + condition-type? + condition-subtype? + make-condition + make-compound-condition + condition-has-type? + condition-ref + simple-conditions + extract-condition + condition-predicate + condition-accessor + define-condition-type/constructor + define-condition-type + condition + + &condition + + &message + make-message-condition + message-condition? + condition-message + + &serious + make-serious-condition + serious-condition? + + &error + make-error + error?) + + (include "internal.scm")) diff --git a/lib/srfi/35/test.sld b/lib/srfi/35/test.sld new file mode 100644 index 00000000..aec2a63b --- /dev/null +++ b/lib/srfi/35/test.sld @@ -0,0 +1,94 @@ +(define-library (srfi 35 test) + (import (scheme base) + (srfi 35 internal) + (chibi test)) + (export run-tests) + (begin + (define (run-tests) + (test-begin "srfi-35: condition types") + (test-group "Adapted from the SRFI 35 examples" + (define-condition-type &c &condition + c? + (x c-x)) + + (define-condition-type &c1 &c + c1? + (a c1-a)) + + (define-condition-type &c2 &c + c2? + (b c2-b)) + (define v1 (make-condition &c1 'x "V1" 'a "a1")) + (define v2 (condition (&c2 + (x "V2") + (b "b2")))) + (define v3 (condition (&c1 + (x "V3/1") + (a "a3")) + (&c2 + (b "b3")))) + (define v4 (make-compound-condition v1 v2)) + (define v5 (make-compound-condition v2 v3)) + + (test #t (c? v1)) + (test #t (c1? v1)) + (test #f (c2? v1)) + (test "V1" (c-x v1)) + (test "a1" (c1-a v1)) + + (test #t (c? v2)) + (test #f (c1? v2)) + (test #t (c2? v2)) + (test "V2" (c-x v2)) + (test "b2" (c2-b v2)) + + (test #t (c? v3)) + (test #t (c1? v3)) + (test #t (c2? v3)) + (test "V3/1" (c-x v3)) + (test "a3" (c1-a v3)) + (test "b3" (c2-b v3)) + + (test #t (c? v4)) + (test #t (c1? v4)) + (test #t (c2? v4)) + (test "V1" (c-x v4)) + (test "a1" (c1-a v4)) + (test "b2" (c2-b v4)) + + (test #t (c? v5)) + (test #t (c1? v5)) + (test #t (c2? v5)) + (test "V2" (c-x v5)) + (test "a3" (c1-a v5)) + (test "b2" (c2-b v5))) + + (test-group "Standard condition hierarchy" + (let ((mc (make-message-condition "foo!"))) + (test #t (message-condition? mc)) + (test "foo!" (condition-message mc)) + + (let ((ec (make-error))) + (test #t (error? ec)) + (test #t (serious-condition? ec)) + + (let ((cc (make-compound-condition ec mc))) + (test #t (error? cc)) + (test #t (serious-condition? cc)) + (test #t (message-condition? cc)) + (test "foo!" (condition-message mc)))))) + + (test-group "R6RS extension: shadowing field names" + (define-condition-type/constructor &a &condition + make-a a? + (val a-val)) + (define-condition-type/constructor &b &a + make-b b? + (val b-val)) + + (define c (make-b 'a 'b)) + + (test 'a (a-val c)) + (test 'b (b-val c))) + + (test-end)))) diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm index e213242d..16201c3e 100644 --- a/lib/srfi/99/records/procedural.scm +++ b/lib/srfi/99/records/procedural.scm @@ -9,7 +9,13 @@ (type? x)) (define (rtd-constructor rtd . o) - (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd)))) + (let ((fields + (if (pair? o) + (map + (lambda (field) + (rtd-field-offset rtd field)) + (vector->list (car o))) + (iota (vector-length (rtd-all-field-names rtd))))) (make (make-constructor (type-name rtd) rtd))) (lambda args (let ((res (make))) @@ -18,7 +24,7 @@ ((null? a) (if (null? p) res (error "not enough args" p))) ((null? p) (error "too many args" a)) (else - (slot-set! rtd res (rtd-field-offset rtd (car p)) (car a)) + (slot-set! rtd res (car p) (car a)) (lp (cdr a) (cdr p))))))))) (define (rtd-predicate rtd) @@ -35,13 +41,13 @@ (define (rtd-field-offset rtd field) (let ((p (type-parent rtd))) - (or (and (type? p) - (rtd-field-offset p field)) - (let ((i (field-index-of (type-slots rtd) field))) + (or (let ((i (field-index-of (type-slots rtd) field))) (and i (if (type? p) (+ i (vector-length (rtd-all-field-names p))) - i)))))) + i))) + (and (type? p) + (rtd-field-offset p field))))) (define (rtd-accessor rtd field) (make-getter (type-name rtd) rtd (rtd-field-offset rtd field))) diff --git a/lib/srfi/99/records/procedural.sld b/lib/srfi/99/records/procedural.sld index b5791992..05a31616 100644 --- a/lib/srfi/99/records/procedural.sld +++ b/lib/srfi/99/records/procedural.sld @@ -1,5 +1,8 @@ (define-library (srfi 99 records procedural) (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator) - (import (chibi) (chibi ast) (srfi 99 records inspection)) + (import (chibi) + (chibi ast) + (only (srfi 1) iota) + (srfi 99 records inspection)) (include "procedural.scm")) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 38c044bc..612d2884 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -8,6 +8,7 @@ (rename (srfi 18 test) (run-tests run-srfi-18-tests)) (rename (srfi 26 test) (run-tests run-srfi-26-tests)) (rename (srfi 27 test) (run-tests run-srfi-27-tests)) + (rename (srfi 35 test) (run-tests run-srfi-35-tests)) (rename (srfi 38 test) (run-tests run-srfi-38-tests)) (rename (srfi 41 test) (run-tests run-srfi-41-tests)) (rename (srfi 69 test) (run-tests run-srfi-69-tests)) @@ -83,6 +84,7 @@ (run-srfi-18-tests) (run-srfi-26-tests) (run-srfi-27-tests) +(run-srfi-35-tests) (run-srfi-38-tests) (run-srfi-41-tests) (run-srfi-69-tests)