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
|
;;; NO SYMBOLS DEFINED HERE
;;; LOAD RETURN: function PROTO (<function> <file>)
;;; RETURN: function PROTO (<function> <stream>)
;;; RETURN: new stream
;;; ASIDE : write SGML representation into <file>
(let*
((symstr (memoize symbol->string eq?))
(tag->string (lambda (token) (symstr (token-gi token))))
(arg->name (lambda (arg) (symstr (arg-name arg))))
(to-strings
(lambda (lst)
(let ((f (lambda (v)
(cond
((string? v) v)
((symbol? v) (symbol->string v))
((number? v) (number->string v))
(else "unknown")))))
(if (pair? lst) (map f lst) (list (f lst))))))
(arg->val (lambda (arg)
(case (arg-type arg)
((DATA CDATA) (plain-tr-string (arg-val arg)))
((OUTPUT) (arg-val arg))
((TOKEN) (strings-join (to-strings (arg-val arg)) " "))
(else (error "[sgml-write]arg->val"
"unhandled arg type" (arg-type arg))))))
(writer
(lambda (port)
(lambda (token)
(case (token-type token)
((PI) (display "<?" port)
(display (data-token-data token) port)
(display ">" port))
((DATA) (display (plain-tr-string (data-token-data token)) port))
((OUTPUT) (display (data-token-data token) port))
((STARTTAG)
(display #"\n<" port) (display (tag->string token) port)
(do ((args (token-args token) (cdr args)))
((null? args))
(if (not (eq? (arg-type (car args)) 'IMPLIED))
(let ((arg (car args)))
(display #"\n " port)
(display (arg->name (car args)) port)
(display "=\"" port)
(display (arg->val arg) port)
(display #\" port))))
(display #">\n" port))
((ENDTAG) (display #"\n</" port)
(display (tag->string token) port)
(display #">\n" port))
(else #t))
token))))
(lambda (outfile)
(lambda (in-stream)
(if (and outfile (not (string=? outfile "-")))
(let ((port (open-output-file outfile)))
(hook 'doc-postprocess 'add
(lambda x (close-output-port port) x))
(stream-map (writer port) in-stream))
(stream-map (writer port) in-stream)))))
|
