blob: 4baa337aed302feb8cd318cc679b4030fac68c51 (
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
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
|
(define (register-plist!)
(define (plist? l)
(and (list? l)
(not (null? l))
(symbol? (car l))))
(define (plist-map! proc plist)
(let loop ((pl plist))
(cond
((null? pl) plist)
((null? (cdr pl)) (error "Malformed plist" plist))
(else
(let ((key (car pl))
(value (cadr pl))
(rest (cddr pl)))
(set-car! (cdr pl)
(proc key value))
(loop rest))))))
(define (plist-filter! pred plist)
(define head (cons #f plist))
(let loop ((pl plist)
(parent-cell head))
(cond
((null? pl) (cdr head))
((null? (cdr pl)) (error "Malformed plist" plist))
(else
(let ((key (car pl))
(value (cadr pl))
(rest (cddr pl)))
(if (pred key value)
(loop rest
(cdr pl))
(loop (begin
(set-cdr! parent-cell rest)
rest)
parent-cell)))))))
;; head is a pair, whose cdr is the plist
;; if found, returns a pair, whose cdr is rest of plist, and cadr is key that was searched for
;; if not found, returns #f
;;
;; the pair indirection is used so that calling set-cdr! on the result allows the plist to be mutated
(define (find-plist-entry key head)
(define plist (cdr head))
(cond
((null? plist) #f)
((equal? key (car plist)) head)
(else (find-plist-entry key (cdr plist)))))
(define (plist-search! plist key failure success)
(define plist-head (cons #t plist))
(define (handle-success head)
(define key-cell (cdr head))
(define val-cell (cddr head))
(define (update new-key new-value obj)
(set-car! key-cell new-key)
(set-car! val-cell new-value)
(values plist obj))
(define (remove obj)
(set-cdr! head (cddr (cdr head)))
(values (cdr plist-head) obj))
(success (car key-cell) (car val-cell) update remove))
(define (handle-failure)
(define (insert value obj)
(values (cons key (cons value plist))
obj))
(define (ignore obj)
(values plist obj))
(failure insert ignore))
(cond
((find-plist-entry key plist-head) => handle-success)
(else (handle-failure))))
(define (plist-size plist)
(/ (length plist) 2))
(define (plist-foreach proc plist)
(let loop ((pl plist))
(if (null? pl) #t
(begin
(proc (car pl) (cadr pl))
(loop (cddr pl))))))
(register-dictionary!
'dictionary? plist?
'dict-map! plist-map!
'dict-filter! plist-filter!
'dict-search! plist-search!
'dict-size plist-size
'dict-for-each plist-foreach))
|
