blob: f90e9680820a73ea3fb88eafc83d0ffa27bda4d7 (
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
46
47
48
49
|
(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)
(define eq-map (make-eq-map))
(define (loop obj 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 obj (cdr rewriters)))))
(define (rewrite obj)
(cond
((or (symbol? obj) (number? obj) (char? obj)
(null? obj) (boolean? obj))
obj)
((eq-map 'contains? obj)
(eq-map 'cycle-counter obj))
(else
(eq-map 'intern! obj)
(loop obj rewriters))))
(rewrite obj))))
|
