blob: 25d926b026912b8beb636da9e53bbac7cd26899c (
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
|
;;; 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)))
((port)
(render port (render-environment)))
((port env)
(let loop ((ch (read-char port))
(acc '()))
(cond
((not ch) ; after an expansion
(loop (read-char port) acc))
((eof-object? ch) ; end of file
(list->string (reverse acc)))
((eq? ch #\#) ; expansion
(let* ((next (peek-char port))
(proc (assq-ref next (render-specials))))
(cond
((eq? next #\\) ; escape character -- #\,( => #,(
(read-char port) ; skip the \
(loop (read-char port) ; continue
(cons ch acc)))
((not proc) ; this character isn't special
(loop (read-char port) ; continue
(cons ch acc)))
(else ; look up the reader and run it
(read-char port) ; skip the character
(loop #f (append (let* ((ins (displayed (eval (proc port) env)))
(out (assoc ins (render-unprintables))))
(if out
((cdr out) next)
(reverse (string->list ins))))
acc))))))
(else (loop (read-char port) ; normal character
(cons ch acc))))))))
(define render-string
(case-lambda
((s) (render-string s (interaction-environment)))
((s env)
(call-with-port (open-input-string s)
(lambda (port)
(render env port))))))
;;; 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
(interaction-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)))
|
