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

Last change on this file since 36480 was 36480, checked in by Kon Lovett, 2 years ago

srfi-111

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