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

Last change on this file since 36153 was 36153, checked in by Kon Lovett, 3 years ago

C5 rel 3.0.0

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