source: project/release/4/box/trunk/box.scm @ 13528

Last change on this file since 13528 was 13528, checked in by Kon Lovett, 12 years ago

Rmvd keyword arg style. Chgd to all tag style for box types.

File size: 7.6 KB
Line 
1;;;; box.scm
2;;;; Kon Lovett, Oct '08
3
4;; Issues
5;;
6;; - All operations inlined & primitive due to high-performance nature.
7;;
8;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
9
10(declare
11  (usual-integrations)
12  (disable-interrupts)
13  (fixnum)
14  (inline)
15  (local)
16  (no-procedure-checks)
17  (no-bound-checks)
18  (disable-warning redef) ;##sys#procedure->string is redefined!
19  (bound-to-procedure
20    ##sys#signal-hook
21    ##sys#procedure->string) )
22
23;;; Prelude
24
25(include "chicken-primitive-object-inlines")
26
27(require-library ports lolevel)
28
29
30;;; Box Structure Support
31
32(define-inline (%make-box tag init)
33  (%make-structure tag init) )
34
35(define-inline (%box-structure-mutable? obj)
36  (%structure-instance? obj 'box!) )
37
38(define-inline (%box-structure-immutable? obj)
39  (%structure-instance? obj 'box) )
40
41(define-inline (%box-structure? obj)
42  (or (%box-structure-mutable? obj)
43      (%box-structure-immutable? obj)) )
44
45(define-inline (%box-structure-tag obj)
46  (and (%box-structure? obj)
47       (%structure-tag obj) ) )
48
49(define-inline (%box-structure-ref box)
50  (%structure-ref box 1) )
51
52(define-inline (%box-structure-set! box obj)
53  (%structure-set!/maybe-immediate box 1 obj) )
54
55
56;;; Box Procedure Support
57
58;; Box Variable
59
60(define-inline (%box-variable-immutable-tag? obj)
61  (%eq? 'boxvar obj) )
62
63(define-inline (%box-variable-mutable-tag? obj)
64  (%eq? 'boxvar! obj) )
65
66(define-inline (%box-variable-tag? obj)
67  (or (%box-variable-mutable-tag? obj)
68      (%box-variable-immutable-tag? obj) ) )
69
70(define-inline (%box-variable? obj)
71  (and-let* ([dat (procedure-data obj)])
72    (%box-variable-tag? dat) ) )
73
74;; Box Location
75
76(define-inline (%box-location-immutable-tag? obj)
77  (%eq? 'boxloc obj) )
78
79(define-inline (%box-location-mutable-tag? obj)
80  (%eq? 'boxloc! obj) )
81
82(define-inline (%box-location-tag? obj)
83  (or (%box-location-mutable-tag? obj)
84      (%box-location-immutable-tag? obj) ) )
85
86(define-inline (%box-location? obj)
87  (and-let* ([dat (procedure-data obj)])
88    (%box-location-tag? dat) ) )
89
90;; Box Procedure
91
92(define-inline (%box-procedure-tag? obj)
93  (or (%box-variable-tag? obj)
94      (%box-location-tag? obj) ) )
95
96(define-inline (%box-procedure-tag obj)
97  (and-let* ([dat (procedure-data obj)]
98             [(%box-procedure-tag? dat)])
99    dat ) )
100
101(define-inline (%box-procedure? obj)
102  (and (%box-procedure-tag obj)
103       #t ) )
104
105(define-inline (%box-procedure-immutable? obj)
106  (and-let* ([dat (procedure-data obj)])
107    (or (%box-variable-immutable-tag? dat)
108        (%box-location-immutable-tag? dat) ) ) )
109
110(define-inline (%box-procedure-mutable? obj)
111  (and-let* ([dat (procedure-data obj)])
112    (or (%box-variable-mutable-tag? dat)
113        (%box-location-mutable-tag? dat) ) ) )
114
115;; Box Procedure Operations
116
117(define-inline (%box-procedure-ref box)
118  (box (lambda (ref set loc) (ref))) )
119
120(define-inline (%box-procedure-set! box obj)
121  (box (lambda (ref set loc) (set obj))) )
122
123(define-inline (%box-procedure-location box)
124  (box (lambda (ref set loc) (loc))) )
125
126;;
127
128(define-inline (%box? obj)
129  (or (%box-structure? obj)
130      (%box-procedure? obj)) )
131
132
133;;; Errors
134
135(define-inline (%box-immutable-error loc box . args)
136  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args) )
137
138(define-inline (%box-type-error loc obj . args)
139  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
140
141
142;;; Print
143
144(define-inline (%box-print box)
145  (let ([val (cond [(%box-structure? box)  (%box-structure-ref box) ]
146                   [(%box-procedure? box)  (%box-procedure-ref box) ] ) ] )
147          (display "#&") (write val) ) )
148
149
150;;; Module box
151
152(module box (;export
153  make-box (make-box-variable finvar) (make-box-location finloc)
154  box? box-variable? box-location?
155  box-mutable? box-immutable?
156  box-set! box-ref
157  box-location
158  box
159  set-box! unbox)
160
161(import
162  scheme
163  (only chicken
164    optional                ;due to #!optional implementation
165    let-optionals           ;due to #!optional implementation
166    define-record-printer
167    let-location
168    and-let*
169    getter-with-setter
170    void
171    set-sharp-read-syntax!
172    ##sys#signal-hook
173    ##sys#procedure->string)
174  (only ports
175    with-output-to-port
176    with-output-to-string)
177  (only lolevel
178    extend-procedure procedure-data
179    make-weak-locative make-locative) )
180
181
182;;; Internals
183
184;; Finishers
185
186(define (finvar tag ref set)
187  (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag) )
188
189(define (finloc tag ref set loc)
190  (extend-procedure (lambda (proc) (proc ref set loc)) tag) )
191
192
193;;; Box
194
195;; Constructers
196
197(define-syntax make-box-variable
198  (syntax-rules ()
199    [(_ ?var)
200     (make-box-variable ?var #f) ]
201    [(_ ?var ?immutable?)
202     #;(identifier? ?var)
203     (finvar
204      (if ?immutable? 'boxvar 'boxvar!)
205      (lambda () ?var)
206      (if ?immutable? (void) (lambda (val) (set! ?var val)))) ] ) )
207
208(define-syntax make-box-location
209  (syntax-rules ()
210    [(_ ?typ ?val)
211     (make-box-location ?typ ?val #f) ]
212    [(_ ?typ ?val ?immutable?)
213     #;(identifier? ?typ)
214     (let-location ([var ?typ ?val])
215       (finloc
216        (if ?immutable? 'boxloc 'boxloc!)
217        (lambda () var)
218        (if ?immutable? (void) (lambda (val) (set! var val)))
219        (lambda () (location var))) ) ] ) )
220
221(define (make-box #!optional init immutable?)
222  (%make-box (if immutable? 'box 'box!) init) )
223
224;; Predicates
225
226(define (box? obj)
227  (%box? obj) )
228
229(define (box-variable? obj)
230  (%box-variable? obj) )
231
232(define (box-location? obj)
233  (%box-location? obj) )
234
235(define (box-immutable? obj)
236  (or (%box-structure-immutable? obj)
237      (%box-procedure-immutable? obj) ) )
238
239(define (box-mutable? obj)
240  (or (%box-structure-mutable? obj)
241      (%box-procedure-mutable? obj) ) )
242
243;; Mutators
244
245(define (box-set! box val)
246  (cond [(%box-structure-tag box) =>
247         (lambda (tag)
248           (case tag
249             [(box!)
250              (%box-structure-set! box val) ]
251             [(box)
252              (%box-immutable-error 'box-set! box val) ] ) ) ]
253        [(%box-procedure-tag box) =>
254         (lambda (tag)
255           (case tag
256             [(boxvar! boxloc!)
257              (%box-procedure-set! box val) ]
258             [(boxvar boxloc)
259              (%box-immutable-error 'box-set! box val) ] ) ) ]
260        [else
261         (%box-type-error 'box-set! box val) ] ) )
262
263;; Assessors
264
265(define box-ref
266  (getter-with-setter
267    (lambda (box)
268      (cond [(%box-structure? box)  (%box-structure-ref box) ]
269            [(%box-procedure? box)  (%box-procedure-ref box) ]
270            [else
271             (%box-type-error 'box-ref box) ] ) )
272    box-set! ) )
273
274(define (box-location box #!optional (weak? #f))
275  (cond [(%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1) ]
276        [(%box-procedure? box)   (box (lambda (ref set loc) (loc))) ]
277        [else
278         (%box-type-error 'box-location box) ] ) )
279
280
281;;; MZ Scheme Style
282
283(define-syntax box
284  (syntax-rules ()
285    [(_ ?arg0 ...)
286     (make-box ?arg0 ...) ] ) )
287
288(define-syntax unbox
289  (syntax-rules ()
290    [(_ ?box)
291     (box-ref ?box) ] ) )
292
293(define-syntax set-box!
294  (syntax-rules ()
295    [(_ ?box ?val)
296     (box-set! ?box ?val) ] ) )
297
298
299;;; Read/Print Syntax
300
301(set-sharp-read-syntax! #\&
302  (lambda (port)
303    (make-box (read port))))
304
305(define-record-printer (box x out)
306  (with-output-to-port out (lambda () (%box-print x))) )
307
308(define-record-printer (box-immutable x out)
309  (with-output-to-port out (lambda () (%box-print x))) )
310
311(set! ##sys#procedure->string
312  (let ([##sys#procedure->string ##sys#procedure->string])
313    (lambda (x)
314                        (if (%box? x)
315                                        (with-output-to-string (lambda () (%box-print x)))
316                                        (##sys#procedure->string x) ) ) ) )
317
318) ;module box
Note: See TracBrowser for help on using the repository browser.