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

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

*-test runner, fix strict-types exposed test variable type rebinding, cannot use type predicates as "trait" predicates

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