Skip to content

Commit 679875d

Browse files
ashinnashinn
authored
Merge pull request #1008 from dpk/srfi-35
Add SRFI 35 support
2 parents 416da21 + 2781739 commit 679875d

7 files changed

Lines changed: 433 additions & 7 deletions

File tree

‎lib/srfi/35.sld‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
(define-library (srfi 35)
2+
(import (srfi 35 internal))
3+
(export make-condition-type
4+
condition-type?
5+
make-condition
6+
condition?
7+
condition-has-type?
8+
condition-ref
9+
make-compound-condition
10+
extract-condition
11+
define-condition-type
12+
condition
13+
14+
&condition
15+
16+
&message
17+
message-condition?
18+
condition-message
19+
20+
&serious
21+
serious-condition?
22+
23+
&error
24+
error?))

‎lib/srfi/35/internal.scm‎

Lines changed: 249 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,249 @@
1+
(define-record-type Simple-Condition
2+
(make-simple-condition)
3+
simple-condition?)
4+
5+
(define-record-type Compound-Condition
6+
(%make-compound-condition components)
7+
compound-condition?
8+
(components compound-condition-components))
9+
10+
(define (make-condition-type id parent field-names)
11+
(make-rtd id
12+
(list->vector
13+
(map
14+
(lambda (field-name)
15+
(list 'immutable field-name))
16+
field-names))
17+
parent))
18+
19+
(define (condition? obj)
20+
(or (simple-condition? obj)
21+
(compound-condition? obj)))
22+
23+
(define (condition-type? obj)
24+
(condition-subtype? obj Simple-Condition))
25+
26+
(define (condition-subtype? maybe-child-ct maybe-parent-ct)
27+
(and (rtd? maybe-child-ct)
28+
(or (eqv? maybe-child-ct maybe-parent-ct)
29+
(condition-subtype? (rtd-parent maybe-child-ct)
30+
maybe-parent-ct))))
31+
32+
(define (condition-type-ancestors ct)
33+
(unfold (lambda (a) (not (condition-type? a)))
34+
(lambda (a) a)
35+
(lambda (a) (rtd-parent a))
36+
ct))
37+
38+
(define (condition-type-common-ancestor ct_1 ct_2)
39+
(let ((ct_1-as (condition-type-ancestors ct_1))
40+
(ct_2-as (condition-type-ancestors ct_2)))
41+
(find (lambda (a)
42+
(memv a ct_2-as))
43+
ct_1-as)))
44+
45+
(define (make-condition ct . plist)
46+
(define *undef* (cons '*undef* '()))
47+
(let* ((field-names (rtd-all-field-names ct))
48+
(field-values (make-vector (vector-length field-names) *undef*)))
49+
(let loop ((property plist))
50+
(if (null? property)
51+
(cond ((vector-any (lambda (name value)
52+
(and (eq? value *undef*) name))
53+
field-names
54+
field-values)
55+
=> (lambda (undef-field-name)
56+
(error "make-condition: value not given for field"
57+
undef-field-name
58+
ct)))
59+
(else
60+
(apply (rtd-constructor ct) (vector->list field-values))))
61+
(let ((idx (vector-index (lambda (x) (eq? x (car property)))
62+
field-names)))
63+
(if idx
64+
(begin
65+
(vector-set! field-values idx (cadr property))
66+
(loop (cddr property)))
67+
(error "make-condition: unknown field" (car property))))))))
68+
69+
(define (make-compound-condition . cs)
70+
(if (= (length cs) 1)
71+
(car cs)
72+
;; SRFI 35 requires at least one component, but R6RS doesn’t;
73+
;; defer to R6RS’s less strict error checking (!)
74+
(%make-compound-condition
75+
(append-map
76+
(lambda (c)
77+
(if (simple-condition? c)
78+
(list c)
79+
(compound-condition-components c)))
80+
cs))))
81+
82+
(define (condition-has-type? c ct)
83+
(if (simple-condition? c)
84+
(is-a? c ct)
85+
(any
86+
(lambda (comp) (condition-has-type? comp ct))
87+
(compound-condition-components c))))
88+
89+
(define (condition-ref c field-name)
90+
(if (simple-condition? c)
91+
((rtd-accessor (record-rtd c) field-name) c)
92+
(condition-ref
93+
(find
94+
(lambda (comp)
95+
(find field-name
96+
(vector->list
97+
(rtd-all-field-names (record-rtd c)))))
98+
(compound-condition-components c))
99+
field-name)))
100+
101+
(define (simple-conditions c)
102+
(if (simple-condition? c)
103+
(list c)
104+
(compound-condition-components c)))
105+
106+
(define (extract-condition c ct)
107+
(if (and (simple-condition? c)
108+
(condition-has-type? c ct))
109+
c
110+
(find
111+
(lambda (comp)
112+
(condition-has-type? comp ct))
113+
(compound-condition-components ct))))
114+
115+
(define (condition-predicate ct)
116+
(lambda (obj)
117+
(and (condition? obj)
118+
(condition-has-type? obj ct))))
119+
(define (condition-accessor ct proc)
120+
(lambda (c)
121+
(cond ((and (simple-condition? c)
122+
(condition-has-type? c ct))
123+
(proc c))
124+
((find (lambda (comp) (condition-has-type? comp ct))
125+
(compound-condition-components c))
126+
=> (lambda (comp)
127+
(proc comp)))
128+
(else (error "condition-accessor: condition does not have the right type"
129+
c ct)))))
130+
131+
(define-syntax define-condition-type/constructor
132+
(syntax-rules ()
133+
((_ name parent constructor predicate
134+
(field-name field-accessor) ...)
135+
(begin
136+
(define ct (make-condition-type 'name
137+
parent
138+
'(field-name ...)))
139+
(define name ct)
140+
(define constructor (rtd-constructor ct))
141+
(define predicate (condition-predicate ct))
142+
(define field-accessor
143+
(condition-accessor ct
144+
(rtd-accessor ct 'field-name))) ...))))
145+
146+
(define-syntax define-condition-type
147+
(syntax-rules ()
148+
((_ name parent predicate (field-name field-accessor) ...)
149+
(define-condition-type/constructor
150+
name parent blah-ignored predicate
151+
(field-name field-accessor) ...))))
152+
153+
(define (%condition . specs)
154+
(define (find-common-field-spec ct name)
155+
(let loop ((more-specs specs))
156+
(if (null? more-specs)
157+
#f
158+
(let* ((other-ct (caar more-specs))
159+
(field-specs (cdar more-specs))
160+
(a (condition-type-common-ancestor ct other-ct)))
161+
(cond ((and (vector-index
162+
(lambda (n)
163+
(eq? n name))
164+
(rtd-all-field-names a))
165+
(assq name field-specs)))
166+
(else (loop (cdr more-specs))))))))
167+
(let loop ((more-specs specs)
168+
(components '()))
169+
(if (null? more-specs)
170+
(apply make-compound-condition (reverse components))
171+
(let* ((this-spec (car more-specs))
172+
(ct (car this-spec))
173+
(field-specs (cdr this-spec))
174+
(field-names (rtd-all-field-names ct))
175+
(field-values
176+
(vector-map
177+
(lambda (field-name)
178+
(cond ((assq field-name field-specs) => cdr)
179+
((find-common-field-spec ct field-name) => cdr)
180+
(else
181+
(error "condition: value not given for field"
182+
field-name
183+
ct))))
184+
field-names)))
185+
(loop
186+
(cdr more-specs)
187+
(cons
188+
(apply (rtd-constructor ct) (vector->list field-values))
189+
components))))))
190+
(define-syntax condition
191+
(syntax-rules ()
192+
((_ (ct (field-name field-value) ...) ...)
193+
(%condition (list ct (cons 'field-name field-value) ...) ...))))
194+
195+
(define &condition Simple-Condition)
196+
197+
(define-condition-type/constructor &message &condition
198+
make-message-condition message-condition?
199+
(message condition-message))
200+
201+
(define-condition-type/constructor &serious &condition
202+
make-serious-condition serious-condition?)
203+
204+
(define-condition-type/constructor &error &serious
205+
make-error error?)
206+
207+
;; (chibi repl) support
208+
(define-method (repl-print-exception (exn condition?) (out output-port?))
209+
(define components (simple-conditions exn))
210+
(define n-components (length components))
211+
(display "CONDITION: " out)
212+
(display n-components out)
213+
(display " component" out)
214+
(if (not (= n-components 1)) (display "s" out))
215+
(display "\n" out)
216+
(for-each
217+
(lambda (component idx)
218+
(define component-type (record-rtd component))
219+
(display " " out)
220+
(display idx out)
221+
(display ". " out)
222+
(display (rtd-name component-type) out)
223+
(display "\n" out)
224+
(let loop ((as (reverse
225+
(condition-type-ancestors component-type)))
226+
(idx 0))
227+
(if (not (null? as))
228+
(let ((a (car as)))
229+
(let a-loop ((fields (vector->list (rtd-field-names a)))
230+
(idx idx))
231+
(if (null? fields)
232+
(loop (cdr as) idx)
233+
(begin
234+
(display " " out)
235+
(display (if (pair? (car fields))
236+
(car (cdar fields))
237+
(car fields))
238+
out)
239+
(if (not (eqv? a component-type))
240+
(begin
241+
(display " (" out)
242+
(display (rtd-name a) out)
243+
(display ")" out)))
244+
(display ": " out)
245+
(write (slot-ref component-type component idx) out)
246+
(display "\n" out)
247+
(a-loop (cdr fields) (+ idx 1)))))))))
248+
components
249+
(iota n-components 1)))

‎lib/srfi/35/internal.sld‎

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
(define-library (srfi 35 internal)
2+
(import (except (scheme base)
3+
define-record-type
4+
;; exclude (srfi 1 immutable) duplicate imports:
5+
map cons list append reverse)
6+
(scheme write)
7+
(only (chibi)
8+
slot-ref
9+
is-a?)
10+
(only (chibi repl) repl-print-exception)
11+
(only (chibi generic) define-method)
12+
;; don’t let people go messing with a compound condition
13+
;; components list:
14+
(srfi 1 immutable)
15+
(srfi 99)
16+
(srfi 133))
17+
(export make-condition-type
18+
condition?
19+
condition-type?
20+
condition-subtype?
21+
make-condition
22+
make-compound-condition
23+
condition-has-type?
24+
condition-ref
25+
simple-conditions
26+
extract-condition
27+
condition-predicate
28+
condition-accessor
29+
define-condition-type/constructor
30+
define-condition-type
31+
condition
32+
33+
&condition
34+
35+
&message
36+
make-message-condition
37+
message-condition?
38+
condition-message
39+
40+
&serious
41+
make-serious-condition
42+
serious-condition?
43+
44+
&error
45+
make-error
46+
error?)
47+
48+
(include "internal.scm"))

0 commit comments

Comments
 (0)