source: project/release/5/box/trunk/box.scm @ 38539

Last change on this file since 38539 was 38539, checked in by Kon Lovett, 15 months ago

*-test runner, style, remove primitive-inlines, separate srfi-111 module, added make-box-mutable & make-box-immutable, no strict-types since has box "generic"

File size: 10.0 KB
Line 
1;;;; box.scm  -*- Scheme -*-
2;;;; Kon Lovett, Apr '20
3;;;; Kon Lovett, Jul '18
4;;;; Kon Lovett, May '17
5;;;; Kon Lovett, Oct '08
6
7;; Issues
8;;
9;; - All operations inlined & primitive due to high-performance nature.
10;;
11;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
12
13(declare
14  (disable-interrupts))
15
16(module box
17
18(;export
19  make-box
20  make-box-mutable
21  make-box-immutable
22  make-box-variable
23  make-box-location
24  box?
25  box-variable?
26  box-location?
27  box-mutable?
28  box-immutable?
29  box-set!
30  box-ref
31  box-swap!
32  box-location
33  make-box-variable-closure
34  make-box-location-closure
35  ;
36  *box-structure?
37  *box-structure-ref
38  *box-structure-set!
39  *box-procedure?
40  *box-procedure-ref
41  *box-procedure-set!)
42
43(import scheme)
44(import (chicken base))
45(import (chicken syntax))
46(import (chicken type))
47(import (chicken foreign))
48(import (only (chicken read-syntax) define-reader-ctor set-sharp-read-syntax!))
49(import (only (chicken port) with-output-to-port with-output-to-string))
50(import (only (chicken memory representation) extend-procedure procedure-data))
51(import (only (chicken locative) make-weak-locative make-locative))
52(import (only type-errors define-error-type))
53
54;;;
55
56;;
57
58(define-type box-struct (or (struct box) (struct box!)))
59(define-type box-closure ((* * * -> *) -> *))
60(define-type box (or box-struct box-closure))
61
62;;; Prelude
63
64(define-inline (->boolean x) (and x #t))
65
66;;; Box Structure Support
67
68(define-record box structure-immutable-value)
69(define-record-type box
70  (make-box-structure-immutable value)
71  box-structure-immutable?
72  (value box-structure-immutable-value box-structure-immutable-value-set!))
73
74(define-record box! structure-mutable-value)
75(define-record-type box!
76  (make-box-structure-mutable value)
77  box-structure-mutable?
78  (value box-structure-mutable-value box-structure-mutable-value-set!))
79
80(define-inline (%box-structure? obj)
81  (or
82    (box-structure-mutable? obj)
83    (box-structure-immutable? obj)) )
84
85(define-inline (%box-structure-ref box)
86  (cond
87    ((box-structure-mutable? box) (box-structure-mutable-value box))
88    ((box-structure-immutable? box) (box-structure-immutable-value box)) ) )
89
90(define-inline (%box-structure-set! box val)
91  (cond
92    ((box-structure-mutable? box) (box-structure-mutable-value-set! box val))
93    ((box-structure-immutable? box) (box-structure-immutable-value-set! box val)) ) )
94
95;;; Box Procedure Support
96
97;; Box Variable
98
99(define-inline (%box-variable-immutable-tag? obj)
100  (eq? 'boxvar obj) )
101
102(define-inline (%box-variable-mutable-tag? obj)
103  (eq? 'boxvar! obj) )
104
105(define-inline (%box-variable-tag? obj)
106  (or
107    (%box-variable-mutable-tag? obj)
108    (%box-variable-immutable-tag? obj) ) )
109
110(define-inline (%box-variable? obj)
111  (and-let* (
112    (dat (procedure-data obj)) )
113    (%box-variable-tag? dat) ) )
114
115;; Box Location
116
117(define-inline (%box-location-immutable-tag? obj)
118  (eq? 'boxloc obj) )
119
120(define-inline (%box-location-mutable-tag? obj)
121  (eq? 'boxloc! obj) )
122
123(define-inline (%box-location-tag? obj)
124  (or
125    (%box-location-mutable-tag? obj)
126    (%box-location-immutable-tag? obj) ) )
127
128(define-inline (%box-location? obj)
129  (and-let* (
130    (dat (procedure-data obj)) )
131    (%box-location-tag? dat) ) )
132
133;; Box Procedure
134
135(define-inline (%box-closure-tag? obj)
136  (or (%box-variable-tag? obj) (%box-location-tag? obj)) )
137
138(define-inline (%box-closure-tag obj)
139  (and-let* (
140    (dat (procedure-data obj))
141    ((%box-closure-tag? dat)) )
142    dat ) )
143
144(define-inline (%box-closure? obj)
145  (->boolean (%box-closure-tag obj)) )
146
147(define-inline (%box-closure-immutable? obj)
148  (and-let* (
149    (dat (procedure-data obj)) )
150    (or
151      (%box-variable-immutable-tag? dat)
152      (%box-location-immutable-tag? dat) ) ) )
153
154(define-inline (%box-closure-mutable? obj)
155  (and-let* (
156    (dat (procedure-data obj)) )
157    (or
158      (%box-variable-mutable-tag? dat)
159      (%box-location-mutable-tag? dat) ) ) )
160
161;; Box Procedure Operations
162
163(define-inline (%box-closure-ref box)
164  (box (lambda (ref set loc) (ref))) )
165
166(define-inline (%box-closure-set! box obj)
167  (box (lambda (ref set loc) (set obj))) )
168
169(define-inline (%box-closure-location box)
170  (box (lambda (ref set loc) (loc))) )
171
172;;
173
174(define-inline (%box? obj)
175  (or
176    (%box-structure? obj)
177    (%box-closure? obj)) )
178
179;; Errors
180
181(define-error-type box-mutable)
182(define-error-type box)
183
184;; Finishers
185
186(: make-box-variable-closure (boolean (-> *) (* -> void) -> box-closure))
187;
188(define (make-box-variable-closure immutable? ref set)
189  (let (
190    (tag (if immutable? 'boxvar 'boxvar!)) )
191    (extend-procedure
192      (lambda (proc)
193        (proc ref set (lambda () (location (ref)))) )
194      tag) ) )
195
196(: make-box-location-closure (boolean (-> *) (* -> void) (-> locative) -> box-closure))
197;
198(define (make-box-location-closure immutable? ref set refloc)
199  (let (
200    (tag (if immutable? 'boxloc 'boxloc!)) )
201    (extend-procedure
202      (lambda (proc) (proc ref set refloc) )
203      tag) ) )
204
205;;; Box
206
207;; Direct calls
208;; For use by high-performance routines (such as core routine replacements)
209
210(: *box-structure? (* -> boolean : box-struct))
211;
212(define (*box-structure? obj)
213  (%box-structure? obj) )
214
215(: *box-structure-ref (box-struct -> *))
216;
217(define (*box-structure-ref box)
218  (%box-structure-ref box) )
219
220(: *box-structure-set! (box-struct * -> void))
221;
222(define (*box-structure-set! box val)
223  (%box-structure-set! box val) )
224
225(: *box-procedure? (* -> boolean : box-closure))
226;
227(define (*box-procedure? obj)
228  (%box-closure? obj) )
229
230(: box-procedure-ref (box-closure -> *))
231;
232(define (*box-procedure-ref box)
233  (%box-closure-ref box) )
234
235(: *box-procedure-set! (box-closure * -> void))
236;
237(define (*box-procedure-set! box val)
238  (%box-closure-set! box val) )
239
240(: *box-ref (box -> *))
241;
242(define (*box-ref box)
243  (cond
244    ((%box-structure? box)  (%box-structure-ref box))
245    ((%box-closure? box)    (%box-closure-ref box))
246    (else
247      (error-box 'box-ref box 'box)) ) )
248
249;; Constructers
250
251(define-syntax make-box-variable
252  (syntax-rules ()
253    ;
254    ((make-box-variable ?var)
255      (make-box-variable ?var #f) )
256    ;
257    ((make-box-variable ?var ?immutable?)
258      #;(identifier? ?var)
259      (make-box-variable-closure
260        ?immutable?
261        (lambda () ?var)
262        (if ?immutable? void (lambda (val) (set! ?var val)))) ) ) )
263
264(define-syntax make-box-location
265  (syntax-rules ()
266    ;
267    ((make-box-location ?typ ?val)
268      (make-box-location ?typ ?val #f) )
269    ;
270    ((make-box-location ?typ ?val ?immutable?)
271      #;(identifier? ?typ)
272      (let-location ((var ?typ ?val))
273        (make-box-location-closure
274          ?immutable?
275          (lambda () var)
276          (if ?immutable? void (lambda (val) (set! var val)))
277          (lambda () (location var))) ) ) ) )
278
279(: make-box (#!optional * boolean -> box-struct))
280;
281(define (make-box #!optional init immutable?)
282  (if immutable?
283    (make-box-structure-immutable init)
284    (make-box-structure-mutable init) ) )
285
286(: make-box-immutable (#!optional * -> box-struct))
287;
288(define (make-box-immutable #!optional init)
289  (make-box-structure-immutable init) )
290
291(: make-box-mutable (#!optional * -> box-struct))
292;
293(define (make-box-mutable #!optional init)
294  (make-box-structure-mutable init) )
295
296;; Predicates
297
298(: box? (* -> boolean : box))
299;
300(define (box? obj)
301  (%box? obj) )
302
303;NOTE these are trait predicates, not type predicates, so not a (DOM -> RNG : TYPE)!
304
305(: box-variable? (* -> boolean))
306;
307(define (box-variable? obj)
308  (%box-variable? obj) )
309
310(: box-location? (* -> boolean))
311;
312(define (box-location? obj)
313  (%box-location? obj) )
314
315(: box-immutable? (* -> boolean))
316;
317(define (box-immutable? obj)
318  (or (box-structure-immutable? obj) (%box-closure-immutable? obj)) )
319
320(: box-mutable? (* -> boolean))
321;
322(define (box-mutable? obj)
323  (or (box-structure-mutable? obj) (%box-closure-mutable? obj)) )
324
325;; Mutators
326
327
328(: box-set! (box * -> void))
329;
330(define (box-set! box val)
331  (cond
332    ((box-structure-immutable? box)
333      (error-box-mutable 'box-set! box) )
334    ((box-structure-mutable? box) (box-structure-mutable-value-set! box val) )
335    (else
336      (case (%box-closure-tag box)
337        ((boxvar! boxloc!) (%box-closure-set! box val) )
338        ((boxvar boxloc)
339          (error-box-mutable 'box-set! box) )
340        (else
341          (error-box 'box-set! box) ) ) ) ) )
342
343#; ;inlined version below
344(define (box-swap! box func . args)
345  (let* (
346    (oval (*box-ref box))
347    (nval (apply func oval args)) )
348    (box-set! box nval)
349    nval ) )
350
351(: box-swap! (box (* #!rest * -> *) #!rest * -> *))
352;
353(define (box-swap! box func . args)
354  (let* (
355    (oval
356      (cond
357        ((box-structure-immutable? box)
358          (error-box-mutable 'box-swap! box))
359        ((box-structure-mutable? box) (box-structure-mutable-value box))
360        (else
361          (case (%box-closure-tag box)
362            ((boxvar! boxloc!) (%box-closure-ref box) )
363            ((boxvar boxloc)
364              (error-box-mutable 'box-swap! box) )
365            (else
366              (error-box 'box-swap! box) ) ) ) ) )
367    (nval
368      (apply func oval args)) )
369    (cond
370      ((box-structure-mutable? box) (box-structure-mutable-value-set! box nval))
371      (else                         (%box-closure-set! box nval)) )
372    nval ) )
373
374;; Assessors
375
376(: box-ref (box -> *))
377;
378(define box-ref
379  (getter-with-setter *box-ref box-set!))
380
381(: box-location (box #!optional boolean -> locative))
382;
383(define (box-location box #!optional (weak? #f))
384  (cond
385    ((%box-structure? box)
386      ((if weak? make-weak-locative make-locative) box 1))
387    ((%box-closure? box)
388      (box (lambda (ref set loc) (loc))))
389    (else
390      (error-box 'box-location box)) ) )
391
392;;; Read/Print Syntax
393
394(define (box-print box port)
395  (let (
396    (val
397      (cond
398        ((%box-structure? box)  (%box-structure-ref box))
399        ((%box-closure? box)    (%box-closure-ref box))
400        (else
401          (error-box 'box-print box)) ) ) )
402          (display "#&" port) (write val port) ) )
403
404(set-sharp-read-syntax! #\&
405  (lambda (p)
406    (make-box-mutable (read p))))
407
408(define-reader-ctor 'box make-box)
409
410(define-record-printer (box box port) (box-print box port))
411(define-record-printer (box! box port) (box-print box port))
412
413) ;module box
Note: See TracBrowser for help on using the repository browser.