blob: c07bc3a39729e0f4dc581ce8a21d6affc11bdef4 (
plain)
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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
;;; schmaltz --- render scheme forms in text
;; every effort has been made to make this portable code, or at least to hide
;; the unportability behind configuration.
(define render
(case-lambda
(()
(render (current-input-port) (render-environment)))
((in)
(render in (render-environment)))
((in env)
(let loop ((ch (read-char in))
(acc '()))
(cond
((not ch) ; after an expansion
(loop (read-char in) acc))
((eof-object? ch) ; end of file
(display (list->string (reverse acc))))
((eq? ch #\#) ; expansion
(let* ((next (peek-char in))
(proc (assq-ref next (render-specials))))
(cond
((eq? next #\\) ; escape character -- #\,( => #,(
(read-char in) ; skip the \
(loop (read-char in) ; continue
(cons ch acc)))
((not proc) ; this character isn't special
(loop (read-char in) ; continue
(cons ch acc)))
(else ; look up the reader and run it
(read-char in) ; skip the character
(loop #f (append (let* ((ins (displayed (eval (proc in) env)))
(out (assoc ins (render-unprintables))))
(if out
((cdr out) next)
(reverse (string->list ins))))
acc))))))
(else (loop (read-char in) ; normal character
(cons ch acc))))))))
(define render-string
(case-lambda
((str) (render-string str (interaction-environment)))
((str env)
(call-with-port (open-input-string str)
(lambda (in)
(render env in))))))
(define (render->string . args)
(call-with-port (open-output-string)
(lambda (out)
(apply render args)
(get-output-string out))))
(define (render-string->string str . args)
(call-with-port (open-output-string)
(lambda (out)
(apply render-string args)
(get-output-string out))))
;;; Configuration
(define render-environment
(make-parameter
(interaction-environment)))
(define render-specials
;; Alist of (CHAR . PROCEDURE) mapping input characters to special reader
;; meanings. Each PROCEDURE should take one parameter, a port.
(make-parameter
(list (cons #\, (lambda (port) (eval (read port) ; standard scheme read
(render-environment))))
#;(cons #\@ (lambda (port) ; wrap the next form in `sxml->html'
`(sxml->html ,(list 'quasiquote (read port))))))))
(define render-unprintables
(make-parameter
(list #;(cons "#<unspecified>" (lambda _ '()))
#;(cons "#!eof" (lambda (ch) (list ch #\#))))))
;;;: Utilities
(define (displayed x)
(call-with-port (open-output-string)
(lambda (port)
(display x port)
(get-output-string port))))
(define (assq-ref key lis)
(let ((val (assq key lis)))
(if val (cdr val) #f)))
(define (unprintable/skip . _)
'())
(define (unprintable/backtrack ch)
(list ch #\#))
|
