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
|
(define debug
(external-procedure "UNREGISTERED::James Clark//Procedure::debug"))
(define max-node-list-debug-length 5)
(define (debug-body x)
`(,(cond ((node-list? x)
(if (node-list-empty? x)
'empty-node-list
`( ,(if (named-node-list? x)
'named-node-list
'node-list)
,(node-list-length x)
,(node-list-reduce
(node-list-head x max-node-list-debug-length)
(lambda (result n)
(string-append result
(cond ((gi n) (string-append "<" (gi n) ">" ))
((equal? 'data-char (node-property 'class-name n)) (data n))
(else "<?>"))))
"" ))))
((sosofo? x) 'sosofo)
((procedure? x) 'procedure)
((style? x) 'style)
((address? x) 'address)
((color? x) 'color)
((color-space? x) 'color-space)
((display-space? x) 'display-space)
((inline-space? x) 'inline-space)
((glyph-id? x) 'glyph-id)
((glyph-subst-table? x) 'glyph-subst-table)
((boolean? x) 'boolean)
((symbol? x) 'symbol)
((list? x) 'list)
((pair? x) 'pair)
((char? x) 'char)
((string? x) 'string)
((quantity? x) 'quantity)
((keyword? x) 'keyword)
(else 'other))
,x))
<!-- Some bits from the dsssl report, mainly from the
Mulberry site
-->
(define (node-list-filter proc nl)
(node-list-reduce nl
(lambda (result snl)
(if (proc snl)
(node-list snl result)
result))
(empty-node-list)))
(define (map f #!rest xs)
(let ((map1 (lambda (f xs) ; bootstrap version for unary F
(let loop ((xs xs))
(if (null? xs)
'()
(cons (f (car xs))
(loop (cdr xs))))))))
(cond ((null? xs)
'())
((null? (cdr xs))
(map1 f (car xs)))
(else
(let loop ((xs xs))
(if (null? (car xs))
'()
(cons (apply f (map1 car xs))
(loop (map1 cdr xs)))))))))
(define (node-list-head nl i)
(if (zero? i)
(empty-node-list)
(node-list (node-list-first nl)
;;; page 136 of dsssl spec appears to be wrong...
(node-list-head (node-list-rest nl)
(- i 1)))))
(define (zero? x) (equal? x 0))
(define (attribute name nl)
(node-list-map (lambda (snl) (named-node name (attributes snl))) nl))
(define (attribute-value name nl)
(node-list-property 'value (attribute name nl)))
(define (node-list-property prop nl) (node-list-map (lambda (snl)
(node-property prop snl default: (empty-node-list))) nl))
|
