source: project/release/5/box/trunk/box-core.scm @ 39171

Last change on this file since 39171 was 38569, checked in by Kon Lovett, 11 months ago

add types include, fix predicate types, reflow

File size: 9.9 KB
Line 
1;;;; box-core.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-core
17
18(;export
19  make-box make-box-mutable make-box-immutable make-box-variable make-box-location
20  box? box-structure? box-variable? box-location?
21  box-mutable? box-immutable?
22  box-set! box-ref
23  box-location
24  box-swap!
25  make-box-variable-closure make-box-location-closure
26  ;
27  *box-structure? *box-structure-ref *box-structure-set!
28  *box-procedure? *box-procedure-ref *box-procedure-set!)
29
30(import scheme)
31(import (chicken base))
32(import (chicken syntax))
33(import (chicken type))
34(import (chicken foreign))
35(import (only (chicken read-syntax) define-reader-ctor set-sharp-read-syntax!))
36(import (only (chicken port) with-output-to-port with-output-to-string))
37(import (only (chicken memory representation) extend-procedure procedure-data))
38(import (only (chicken locative) make-weak-locative make-locative))
39(import (only type-errors define-error-type))
40
41;;;
42
43;;
44
45(include "box.types")
46
47;;; Prelude
48
49(define-inline (->boolean x) (and x #t))
50
51;;; Box Structure Support
52
53(define-record box structure-immutable-value)
54(define-record-type box
55  (make-box-structure-immutable value)
56  box-structure-immutable?
57  (value box-structure-immutable-value box-structure-immutable-value-set!))
58
59(define-record box! structure-mutable-value)
60(define-record-type box!
61  (make-box-structure-mutable value)
62  box-structure-mutable?
63  (value box-structure-mutable-value box-structure-mutable-value-set!))
64
65(define-inline (%box-structure? obj)
66  (or (box-structure-mutable? obj) (box-structure-immutable? obj)) )
67
68(define-inline (%box-structure-ref box)
69  (cond
70    ((box-structure-mutable? box)   (box-structure-mutable-value box))
71    ((box-structure-immutable? box) (box-structure-immutable-value box)) ) )
72
73(define-inline (%box-structure-set! box val)
74  (cond
75    ((box-structure-mutable? box)   (box-structure-mutable-value-set! box val))
76    ((box-structure-immutable? box) (box-structure-immutable-value-set! box val)) ) )
77
78;;; Box Procedure Support
79
80;; Box Variable
81
82(define-inline (%box-variable-immutable-tag? obj) (eq? 'boxvar obj))
83(define-inline (%box-variable-mutable-tag? obj)   (eq? 'boxvar! obj))
84
85(define-inline (%box-variable-tag? obj)
86  (or (%box-variable-mutable-tag? obj) (%box-variable-immutable-tag? obj)) )
87
88(define-inline (%box-variable? obj)
89  (and-let* (
90    (dat (procedure-data obj)) )
91    (%box-variable-tag? dat) ) )
92
93;; Box Location
94
95(define-inline (%box-location-immutable-tag? obj) (eq? 'boxloc obj))
96(define-inline (%box-location-mutable-tag? obj)   (eq? 'boxloc! obj))
97
98(define-inline (%box-location-tag? obj)
99  (or (%box-location-mutable-tag? obj) (%box-location-immutable-tag? obj)) )
100
101(define-inline (%box-location? obj)
102  (and-let* (
103    (dat (procedure-data obj)) )
104    (%box-location-tag? dat) ) )
105
106;; Box Procedure
107
108(define-inline (%box-closure-tag? obj)
109  (or (%box-variable-tag? obj) (%box-location-tag? obj)) )
110
111(define-inline (%box-closure-tag obj)
112  (and-let* (
113    (dat (procedure-data obj))
114    ((%box-closure-tag? dat)) )
115    dat ) )
116
117(define-inline (%box-closure? obj)
118  (->boolean (%box-closure-tag obj)) )
119
120(define-inline (%box-closure-immutable? obj)
121  (and-let* (
122    (dat (procedure-data obj)) )
123    (or
124      (%box-variable-immutable-tag? dat)
125      (%box-location-immutable-tag? dat) ) ) )
126
127(define-inline (%box-closure-mutable? obj)
128  (and-let* (
129    (dat (procedure-data obj)) )
130    (or
131      (%box-variable-mutable-tag? dat)
132      (%box-location-mutable-tag? dat) ) ) )
133
134;; Box Procedure Operations
135
136(define-inline (%box-closure-ref box)       (box (lambda (ref set loc) (ref))))
137(define-inline (%box-closure-set! box obj)  (box (lambda (ref set loc) (set obj))))
138(define-inline (%box-closure-location box)  (box (lambda (ref set loc) (loc))))
139
140;;
141
142(define-inline (%box? obj) (or (%box-structure? obj) (%box-closure? obj)))
143
144;; Errors
145
146(define-error-type box-mutable)
147(define-error-type box)
148
149;; Finishers
150
151(: make-box-variable-closure (boolean (-> *) (* -> void) -> box-closure))
152(: make-box-location-closure (boolean (-> *) (* -> void) (-> locative) -> box-closure))
153
154(define (make-box-variable-closure immutable? ref set)
155  (let (
156    (tag (if immutable? 'boxvar 'boxvar!)) )
157    (extend-procedure
158      (lambda (proc) (proc ref set (lambda () (location (ref)))))
159      tag) ) )
160
161(define (make-box-location-closure immutable? ref set refloc)
162  (let (
163    (tag (if immutable? 'boxloc 'boxloc!)) )
164    (extend-procedure
165      (lambda (proc) (proc ref set refloc) )
166      tag) ) )
167
168;;; Box
169
170;; Direct calls
171;; For use by high-performance routines (such as core routine replacements)
172
173(: *box-structure?      (* -> boolean : box-struct))
174(: *box-structure-ref   (box-struct -> *))
175(: *box-structure-set!  (box-struct * -> void))
176(: *box-procedure?      (* -> boolean : box-closure))
177(: *box-procedure-ref   (box-closure -> *))
178(: *box-procedure-set!  (box-closure * -> void))
179(: *box-ref             (box -> *))
180
181(define (*box-structure? obj)           (%box-structure? obj))
182(define (*box-structure-ref box)        (%box-structure-ref box))
183(define (*box-structure-set! box val)   (%box-structure-set! box val))
184(define (*box-procedure? obj)           (%box-closure? obj))
185(define (*box-procedure-ref box)        (%box-closure-ref box))
186(define (*box-procedure-set! box val)   (%box-closure-set! box val))
187
188(define (*box-ref box)
189  (cond
190    ((%box-structure? box)  (%box-structure-ref box))
191    ((%box-closure? box)    (%box-closure-ref box))
192    (else
193      (error-box 'box-ref box 'box)) ) )
194
195;; Constructers
196
197(define-syntax make-box-variable
198  (syntax-rules ()
199    ;
200    ((make-box-variable ?var)
201      (make-box-variable ?var #f) )
202    ;
203    ((make-box-variable ?var ?immutable?)
204      #;(identifier? ?var)
205      (make-box-variable-closure
206        ?immutable?
207        (lambda () ?var)
208        (if ?immutable? void (lambda (val) (set! ?var val)))) ) ) )
209
210(define-syntax make-box-location
211  (syntax-rules ()
212    ;
213    ((make-box-location ?typ ?val)
214      (make-box-location ?typ ?val #f) )
215    ;
216    ((make-box-location ?typ ?val ?immutable?)
217      #;(identifier? ?typ)
218      (let-location ((var ?typ ?val))
219        (make-box-location-closure
220          ?immutable?
221          (lambda () var)
222          (if ?immutable? void (lambda (val) (set! var val)))
223          (lambda () (location var))) ) ) ) )
224
225(: make-box (#!optional * boolean -> box-struct))
226(: make-box-immutable (#!optional * -> box-struct))
227(: make-box-mutable (#!optional * -> box-struct))
228
229(define (make-box #!optional init immutable?)
230  (if immutable?
231    (make-box-structure-immutable init)
232    (make-box-structure-mutable init) ) )
233
234(define (make-box-immutable #!optional init)  (make-box-structure-immutable init))
235(define (make-box-mutable #!optional init)    (make-box-structure-mutable init))
236
237;; Predicates
238
239(: box?           (* -> boolean : box))
240(: box-structure? (* -> boolean : box-struct))
241(: box-variable?  (* -> boolean : box-closure))
242(: box-location?  (* -> boolean : box-closure))
243(: box-immutable? (* -> boolean : box))
244(: box-mutable?   (* -> boolean : box))
245
246(define (box? obj)            (%box? obj))
247(define (box-structure? obj)  (%box-structure? obj))
248(define (box-variable? obj)   (%box-variable? obj))
249(define (box-location? obj)   (%box-location? obj))
250(define (box-immutable? obj)  (or (box-structure-immutable? obj) (%box-closure-immutable? obj)))
251(define (box-mutable? obj)    (or (box-structure-mutable? obj) (%box-closure-mutable? obj)))
252
253;; Accessors
254
255(: box-set!       (box * -> void))
256(: box-ref        (box -> *))
257(: box-location   (box #!optional boolean -> locative))
258
259(define (box-set! box val)
260  (cond
261    ((box-structure-immutable? box)
262      (error-box-mutable 'box-set! box) )
263    ((box-structure-mutable? box) (box-structure-mutable-value-set! box val) )
264    (else
265      (case (%box-closure-tag box)
266        ((boxvar! boxloc!) (%box-closure-set! box val) )
267        ((boxvar boxloc)
268          (error-box-mutable 'box-set! box) )
269        (else
270          (error-box 'box-set! box) ) ) ) ) )
271
272(define box-ref (getter-with-setter *box-ref box-set!))
273
274(define (box-location box #!optional (weak? #f))
275  (cond
276    ((%box-structure? box)
277      ((if weak? make-weak-locative make-locative) box 1))
278    ((%box-closure? box)
279      (box (lambda (ref set loc) (loc))))
280    (else
281      (error-box 'box-location box)) ) )
282
283;; Operations
284
285(: box-swap! (box (* #!rest -> *) #!rest -> *))
286
287(define (box-swap! box func . args)
288  #; ;inlined version below
289  (let ((nval (apply func (*box-ref box) args)))
290    (box-set! box nval)
291    nval )
292  (let* (
293    (oval
294      (cond
295        ((box-structure-immutable? box)
296          (error-box-mutable 'box-swap! box))
297        ((box-structure-mutable? box) (box-structure-mutable-value box))
298        (else
299          (case (%box-closure-tag box)
300            ((boxvar! boxloc!) (%box-closure-ref box) )
301            ((boxvar boxloc)
302              (error-box-mutable 'box-swap! box) )
303            (else
304              (error-box 'box-swap! box) ) ) ) ) )
305    (nval
306      (apply func oval args)) )
307    (cond
308      ((box-structure-mutable? box) (box-structure-mutable-value-set! box nval))
309      (else                         (%box-closure-set! box nval)) )
310    nval ) )
311
312;; Read/Print Syntax
313
314(: box-print (* output-port -> void))
315
316(define (box-print box port)
317  (let (
318    (val
319      (cond
320        ((%box-structure? box)  (%box-structure-ref box))
321        ((%box-closure? box)    (%box-closure-ref box))
322        (else
323          (error-box 'box-print box)) ) ) )
324          (display "#&" port) (write val port) ) )
325
326(set-sharp-read-syntax! #\& (lambda (p) (make-box-mutable (read p))))
327
328(define-reader-ctor 'box make-box)
329
330(define-record-printer (box box port) (box-print box port))
331(define-record-printer (box! box port) (box-print box port))
332
333) ;module box-core
Note: See TracBrowser for help on using the repository browser.