blob: 61849c11ef9b9c29b871e9b69e6b61a35adfcb39 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
(define-library (cuprate implementation)
(import (scheme base))
(cond-expand
(chicken-5 (import (cuprate implementation chicken)))
(gauche (import (cuprate implementation gauche)))
(foment (import (cuprate implementation foment)))
(chibi (import (cuprate implementation chibi)))
(skint (import (cuprate implementation skint)))
(sagittarius (import (cuprate implementation sagittarius)))
(else (import (cuprate implementation r7rs))))
(export default-rewriters rewrite-enter pretty-print
alist->default-dictionary default-test-dto)
(begin
(define (default-on-pair rewrite pair)
(cons (rewrite (car pair)) (rewrite (cdr pair))))
(define (default-on-vector rewrite vec)
(vector-map rewrite vec))
(define (default-on-error rewrite eobj)
`(error ,(rewrite (error-object-message eobj))
,@(map rewrite (error-object-irritants eobj))))
(define default-rewriters
(append implementation-rewriters
(list (cons pair? default-on-pair)
(cons vector? default-on-vector)
(cons error-object? default-on-error))))
(define (rewrite-enter rewriters obj)
(letrec ((eq-map (make-eq-map))
(rewrite
(lambda (obj)
(if (eq-map 'contains? obj)
(eq-map 'cycle-counter obj)
(begin
(eq-map 'intern! obj)
(let loop ((rewriters rewriters))
(cond
((null? rewriters) obj)
(((caar rewriters) obj)
(let ((new-obj ((cdar rewriters) rewrite obj)))
(if (eq-map 'cycle-used? obj)
(list (eq-map 'cycle-counter)
'=
new-obj)
new-obj)))
(else (loop (cdr rewriters))))))))))
(rewrite obj)))))
|
