source: project/release/3/proplist/proplist.scm

Last change on this file was 6212, checked in by Kon Lovett, 13 years ago

What the f*

File size: 9.8 KB
Line 
1;;;; proplist.scm
2;;;; Kon Lovett, Mar 5 2005
3
4;; Issues
5;;
6;; - Not completely CL compatible semantics or procedure symbols.
7;;
8;; - Some property operations are not very efficient.
9
10(use srfi-1 extras lolevel srfi-69)
11(use miscmacros)
12
13(eval-when (compile)
14        (declare
15        (usual-integrations)
16        (fixnum)
17                (inline)
18                (import
19                  ##sys#slot
20                  ##sys#setslot
21                  ##sys#fudge)
22                (bound-to-procedure
23                  ##sys#slot
24                  ##sys#setslot
25                  ##sys#fudge)
26                (export
27                        proplist-equal proplist-member
28                        proplist-extraslot proplist-procslot
29                        proplist-procedure
30                        getprop putprop! setprop!
31                        remprop! remprop/all!
32                        proplist
33                        proplist->alist alist->proplist
34                        set-proplist!
35                        print-proplist)
36        )
37)
38
39;;; Variables & Constants
40
41(define has-extraslot-feature?
42        #;(not (not (memq #:extraslot (features))))
43        (##sys#fudge 33) )
44
45(define-constant EMPTY-PROPLIST '())
46
47(define $equals? eq?)
48(define $member memq)
49(define *use-extraslot* has-extraslot-feature?)
50(define *use-procslot* #t)
51
52;;; Parameters
53
54(define-parameter proplist-equal
55        $equals?
56  (lambda (x)
57    (if (procedure? x)
58      (begin (set! $equals? x) x)
59      (proplist-equal))))
60
61(define-parameter proplist-member
62        $member
63  (lambda (x)
64    (if (procedure? x)
65      (begin (set! $member x) x)
66      (proplist-member))))
67
68(define-parameter proplist-extraslot
69        *use-extraslot*
70  (lambda (x)
71    (when (boolean? x)
72      (set! *use-extraslot* (and has-extraslot-feature? x)))
73    *use-extraslot*))
74
75(define-parameter proplist-procslot
76        *use-procslot*
77  (lambda (x)
78    (when (boolean? x)
79      (set! *use-procslot* x))
80    *use-procslot*))
81
82;;; Symbol Slot
83
84(define-inline (extraslot-ref sym #!optional default)
85        (let ([plist (##sys#slot sym 2)])
86                (if ($equals? (void) plist) default plist) ) )
87
88(define-inline (extraslot-set! sym plist)
89        (##sys#setslot sym 2 plist) )
90
91;;; Primitive Property List Accessors
92
93(define *property-hashtable* (make-hash-table eq? hash-by-identity))
94
95(define (proplist-ref name)
96        (cond [(and *use-extraslot* (symbol? name)) (extraslot-ref name EMPTY-PROPLIST)]
97        [(and *use-procslot* (procedure? name)) (procedure-data name)]
98        [(list? name) name]
99        [else (hash-table-ref/default *property-hashtable* name EMPTY-PROPLIST)] ) )
100
101(define (proplist-set! name proplist)
102        (cond [(and *use-extraslot* (symbol? name)) (extraslot-set! name proplist) name]
103        [(and *use-procslot* (procedure? name)) (set-procedure-data! name proplist) name]
104        [(list? name) proplist]
105        [else (hash-table-set! *property-hashtable* name proplist) name] ) )
106
107(define (delete-properties! proplist . props)
108        (let ([skip? #f])
109                (remove!
110                        (lambda (elm)
111                                (cond [skip? (set! skip? #f) #t]
112              [($member elm props) (set! skip? #t) #t]
113              [else #f] ) )
114                        proplist) ) )
115
116(define (delete-property! proplist . props)
117        (let ([skip? #f] [found? #f])
118                (remove!
119                        (lambda (elm)
120                                (and (not found?)
121             (cond [skip? (set! found? #t) (set! skip? #f) #t]
122                   [($member elm props) (set! skip? #t) #t]
123                   [else #f] ) ) )
124                        proplist) ) )
125
126;;; Property List Accessors
127
128(define (proplist-procedure proc)
129        (extend-procedure proc EMPTY-PROPLIST) )
130
131;; getprop Name Property [Default]
132;; -- Returns the first property value of name, or the optional default
133;; value, when no such property.
134;;
135;; Name - arbitrary object, but not a hash table
136;; Property - property key, an arbitrary object
137;; Default - optional value to return when no such property, default #f
138;;
139;;              Or, providing a dis-embodied property list
140;;
141;; -- Gets the property value.
142;;
143;; Name - hash table
144;; Property - property key, an arbitrary object
145;; Default - optional value to return when no such property, default #f
146
147(define (getprop name prop #!optional def)
148        (if (hash-table? name)
149      (hash-table-ref/default name prop def)
150      (let loop ([pl (proplist-ref name)])
151        (if (null? pl)
152            def
153            (if ($equals? prop (car pl))
154                (cadr pl)
155                (loop (cddr pl)))))))
156
157;; putprop! Name Property Value
158;; -- Sets the first property of name to value. Does not replace an
159;; existing property!
160;;
161;; Name - arbitrary object, but not a hash table
162;; Property - property key, an arbitrary object
163;; Value - property value, an arbitrary object
164;;
165;;              Or, providing a dis-embodied property list
166;;
167;; -- Sets the property to value.
168;;
169;; Name - hash table
170;; Property - property key, an arbitrary object
171;; Value - property value, an arbitrary object
172
173(define (putprop! name . pairs)
174        (if (hash-table? name)
175      (let loop ([pairs pairs])
176        (unless (null? pairs)
177          (let ([prop (car pairs)]
178                [next (cdr pairs)])
179            (if (null? next)
180                (error 'putprop! "must pairs of key - value" pairs)
181                (begin
182                  (hash-table-set! name prop (car next))
183                  (loop (cdr next)))))))
184      (let loop ([pairs pairs] [pl (proplist-ref name)])
185        (if (null? pairs)
186            (proplist-set! name pl)
187            (let ([prop (car pairs)]
188                  [next (cdr pairs)])
189              (if (null? next)
190                  (error 'putprop! "must pairs of key - value" pairs)
191                  (loop (cdr next) (cons prop (cons (car next) pl)))))))))
192
193;; setprop! Name Property Value
194;; -- Sets the one & only property of name to value.
195;;
196;; Name - arbitrary object, but not a hash table
197;; Property - property key, an arbitrary object
198;; Value - property value, an arbitrary object
199;;
200;;              Or, providing a dis-embodied property list
201;;
202;; -- Sets the property to value.
203;;
204;; Name - hash table
205;; Property - property key, an arbitrary object
206;; Value - property value, an arbitrary object
207
208(define (setprop! name . pairs)
209        (if (hash-table? name)
210      (let loop ([pairs pairs])
211        (unless (null? pairs)
212          (let ([prop (car pairs)]
213                [next (cdr pairs)])
214            (if (null? next)
215                (error 'setprop! "must pairs of key - value" pairs)
216                (begin
217                  (hash-table-set! name prop (car next))
218                  (loop (cdr next)))))))
219      (letrec (
220          [delall
221            (lambda (pairs props)
222              (if (null? pairs)
223                  (apply remprop/all! name props)
224                  (let ([prop (car pairs)]
225                        [next (cdr pairs)])
226                    (if (null? next)
227                        (error 'setprop! "must pairs of key - value" pairs)
228                        (delall (cdr next) (cons prop props))))))])
229        (apply putprop! (delall pairs EMPTY-PROPLIST) pairs))))
230
231;; remprop! Name [Property ...]
232;; -- Deletes the first property of name.
233;;
234;; Name - arbitrary object, but not a hash table
235;; Property - property key, an arbitrary object
236;;
237;;              Or, providing a dis-embodied property list
238;;
239;; -- Deletes the property.
240;;
241;; Name - hash table
242;; Property - property key, an arbitrary object
243
244(define (remprop! name . props)
245        (if (hash-table? name)
246      (let loop ([props props])
247        (unless (null? props)
248          (hash-table-delete! name (car props))
249          (loop (cdr props))))
250      (proplist-set! name (apply delete-property! (proplist-ref name) props))))
251
252;; remprop/all! Name [Property ...]
253;; -- Deletes every property of name matching the specified key.
254;;
255;; Name - arbitrary object, but not a hash table
256;; Property - property key, an arbitrary object
257
258(define (remprop/all! name . props)
259        (if (hash-table? name)
260      (let loop ([props props])
261        (unless (null? props)
262          (hash-table-delete! name (car props))
263          (loop (cdr props))))
264      (proplist-set! name (apply delete-properties! (proplist-ref name) props))))
265
266;; -- Returns a proplist of the first property value of name for every property
267;; key specified. All properties when no key specified.
268;;
269(define (proplist name . props)
270        (cond [(hash-table? name)
271          (let ([pl EMPTY-PROPLIST])
272            (hash-table-walk name
273              (lambda (key value)
274                (when (or (null? props) ($member key props))
275                  (set! pl (cons key (cons value pl))))))
276            pl)]
277        [(null? props)
278          (proplist-ref name)]
279        [else
280          (let ([skip? #f] [take? #f])
281            (filter
282              (lambda (elm)
283                (cond [skip? (set! skip? #f) #f]
284                      [take? (set! take? #f) #t]
285                      [($member elm props) (set! take? #t) #t]
286                      [else (set! skip? #t) #f]))
287              (proplist-ref name)) ) ] ) )
288
289;; proplist->alist Name [Property ...]
290;; -- Returns the first property value of name for every property
291;; key specified, as an association list. All properties when no key
292;; specified.
293;;
294;; Name - arbitrary object, but not a hash table
295;; Property - property key, an arbitrary object
296
297(define-inline (%proplist->alist! pl)
298        (map! (lambda (lst) (set-cdr! lst (cadr lst)) lst) (chop pl 2)) )
299
300(define (proplist->alist name . props)
301        (let ([pl (apply proplist name props)])
302                (%proplist->alist! (if (null? props) (list-copy pl) pl)) ) )
303
304;;
305
306(define (unzip-alist alist)
307        (let loop ([alist alist] [keys '()] [vals '()])
308                (if (null? alist)
309        (values (reverse! keys) (reverse! vals))
310        (let ([elm (car alist)])
311                                (if (pair? elm)
312            (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
313            (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
314
315(define-inline (%alist->proplist proc alist)
316        (let-values (([k v] (unzip-alist alist)))
317                (fold-right proc '() k v) ) )
318
319(define (alist->proplist alist . props)
320        (%alist->proplist
321                (if (null? props)
322        cons*
323        (lambda (k v l) (if ($member k props) (cons k (cons v l)) l)))
324                alist) )
325
326;;; Property List I/O
327
328(define (print-proplist name #!optional (port (current-output-port)))
329        (fprintf port "#,(proplist ~S ~S)" name (proplist-ref name)))
330
331(define (set-proplist! name proplist)
332        (proplist-set! name proplist))
333
334;; Read external text representation of a property list.
335
336(define-reader-ctor 'proplist set-proplist!)
Note: See TracBrowser for help on using the repository browser.