blob: 82a275c83f0f4a00ba55912beecdb600dd34077e (
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
|
(define-library (cuprate rewriters)
(import (scheme base) (scheme write)
(chicken memory representation)
(chicken condition))
(export rewriters rewrite)
(begin
(define (default-on-pair pair)
(cons (rewrite (car pair))
(rewrite (cdr pair))))
(define (default-on-vector vec)
(vector-map rewrite vec))
(define (default-on-error error)
(cons 'error
(cons (error-object-message error)
(error-object-irritants error))))
(define (default-on-condition cond)
(map rewrite (condition->list cond)))
(define (default-on-record rec)
`(record (name ,(rewrite (record-instance-type rec)))
(elements
,(vector-map rewrite (record->vector rec)))))
(define rewriters
(make-parameter
`((,pair? . ,default-on-pair)
(,vector? . ,default-on-vector)
(,error-object? . ,default-on-error)
(,condition? . ,default-on-condition)
(,record-instance? . ,default-on-record))))
(define (rewrite obj)
(let loop ((rewriters (rewriters)))
(cond
((null? rewriters) obj)
(((caar rewriters) obj) ((cdar rewriters) obj))
(else (loop (cdr rewriters))))))))
|
