source: project/release/4/box/trunk/box.scm @ 13616

Last change on this file since 13616 was 13616, checked in by Kon Lovett, 11 years ago

Added primitive inlines.

File size: 7.4 KB
Line 
1;;;; box.scm
2;;;; Kon Lovett, Oct '08
3
4;; Issues
5;;
6;; - All operations inlined & primitive due to high-performance nature.
7;;
8;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
9
10(declare
11  (usual-integrations)
12  (disable-interrupts)
13  (fixnum)
14  (inline)
15  (local)
16  (no-procedure-checks)
17  (no-bound-checks)
18  (disable-warning redef) ;##sys#procedure->string is redefined!
19  (bound-to-procedure
20    ##sys#signal-hook
21    ##sys#procedure->string))
22
23;;; Prelude
24
25(include "chicken-primitive-object-inlines")
26
27(require-library ports lolevel)
28
29;;
30
31(define-inline (%->boolean obj) (and obj #t))
32
33
34;;; Box Structure Support
35
36(define-inline (%make-box tag init) (%make-structure tag init))
37
38(define-inline (%box-structure-mutable? obj) (%structure-instance? obj 'box!))
39
40(define-inline (%box-structure-immutable? obj) (%structure-instance? obj 'box))
41
42(define-inline (%box-structure? obj
43  (or (%box-structure-mutable? obj) (%box-structure-immutable? obj)))
44
45(define-inline (%box-structure-tag obj) (and (%box-structure? obj) (%structure-tag obj)))
46
47(define-inline (%box-structure-ref box) (%structure-ref box 1))
48
49(define-inline (%box-structure-set! box obj) (%structure-set!/maybe-immediate box 1 obj))
50
51
52;;; Box Procedure Support
53
54;; Box Variable
55
56(define-inline (%box-variable-immutable-tag? obj) (%eq? 'boxvar obj))
57
58(define-inline (%box-variable-mutable-tag? obj) (%eq? 'boxvar! obj))
59
60(define-inline (%box-variable-tag? obj)
61  (or (%box-variable-mutable-tag? obj) (%box-variable-immutable-tag? obj)))
62
63(define-inline (%box-variable? obj)
64  (and-let* ((dat (procedure-data obj)))
65    (%box-variable-tag? dat)))
66
67;; Box Location
68
69(define-inline (%box-location-immutable-tag? obj) (%eq? 'boxloc obj))
70
71(define-inline (%box-location-mutable-tag? obj) (%eq? 'boxloc! obj))
72
73(define-inline (%box-location-tag? obj)
74  (or (%box-location-mutable-tag? obj) (%box-location-immutable-tag? obj)))
75
76(define-inline (%box-location? obj)
77  (and-let* ((dat (procedure-data obj)))
78    (%box-location-tag? dat)))
79
80;; Box Procedure
81
82(define-inline (%box-procedure-tag? obj) (or (%box-variable-tag? obj) (%box-location-tag? obj)))
83
84(define-inline (%box-procedure-tag obj)
85  (and-let* ((dat (procedure-data obj))
86             ((%box-procedure-tag? dat)))
87    dat))
88
89(define-inline (%box-procedure? obj) (%->boolean (%box-procedure-tag obj)))
90
91(define-inline (%box-procedure-immutable? obj)
92  (and-let* ((dat (procedure-data obj)))
93    (or (%box-variable-immutable-tag? dat) (%box-location-immutable-tag? dat))))
94
95(define-inline (%box-procedure-mutable? obj)
96  (and-let* ((dat (procedure-data obj)))
97    (or (%box-variable-mutable-tag? dat) (%box-location-mutable-tag? dat))))
98
99;; Box Procedure Operations
100
101(define-inline (%box-procedure-ref box) (box (lambda (ref set loc) (ref))))
102
103(define-inline (%box-procedure-set! box obj) (box (lambda (ref set loc) (set obj))))
104
105(define-inline (%box-procedure-location box) (box (lambda (ref set loc) (loc))))
106
107;;
108
109(define-inline (%box? obj) (or (%box-structure? obj) (%box-procedure? obj)))
110
111
112;;; Errors
113
114(define-inline (%box-immutable-error loc box . args)
115  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args))
116
117(define-inline (%box-type-error loc obj . args)
118  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args))
119
120
121;;; Print
122
123(define-inline (%box-print box)
124  (let ((val (cond ((%box-structure? box)  (%box-structure-ref box))
125                   ((%box-procedure? box)  (%box-procedure-ref box)))))
126          (display "#&") (write val)))
127
128
129;;; Module box
130
131(module box (;export
132  make-box (make-box-variable finvar) (make-box-location finloc)
133  box? box-variable? box-location?
134  box-mutable? box-immutable?
135  box-set! box-ref
136  box-location
137  box
138  set-box! unbox)
139
140(import
141  scheme
142  (only chicken
143    optional                ;due to #!optional implementation
144    let-optionals           ;due to #!optional implementation
145    define-reader-ctor
146    define-record-printer
147    let-location
148    and-let*
149    getter-with-setter
150    void
151    set-sharp-read-syntax!
152    ##sys#signal-hook
153    ##sys#procedure->string)
154  (only ports
155    with-output-to-port
156    with-output-to-string)
157  (only lolevel
158    extend-procedure procedure-data
159    make-weak-locative make-locative))
160
161
162;;; Internals
163
164;; Finishers
165
166(define (finvar tag ref set)
167  (extend-procedure (lambda (proc) (proc ref set (lambda () (location (ref))))) tag))
168
169(define (finloc tag ref set loc)
170  (extend-procedure (lambda (proc) (proc ref set loc)) tag))
171
172
173;;; Box
174
175;; Constructers
176
177(define-syntax make-box-variable
178  (syntax-rules ()
179    ((_ ?var)
180     (make-box-variable ?var #f))
181    ((_ ?var ?immutable?)
182     #;(identifier? ?var)
183     (finvar
184      (if ?immutable? 'boxvar 'boxvar!)
185      (lambda () ?var)
186      (if ?immutable? (void) (lambda (val) (set! ?var val)))))))
187
188(define-syntax make-box-location
189  (syntax-rules ()
190    ((_ ?typ ?val)
191     (make-box-location ?typ ?val #f))
192    ((_ ?typ ?val ?immutable?)
193     #;(identifier? ?typ)
194     (let-location ((var ?typ ?val))
195       (finloc
196        (if ?immutable? 'boxloc 'boxloc!)
197        (lambda () var)
198        (if ?immutable? (void) (lambda (val) (set! var val)))
199        (lambda () (location var)))))))
200
201(define (make-box #!optional init immutable?) (%make-box (if immutable? 'box 'box!) init))
202
203;; Predicates
204
205(define (box? obj) (%box? obj))
206
207(define (box-variable? obj) (%box-variable? obj))
208
209(define (box-location? obj) (%box-location? obj))
210
211(define (box-immutable? obj) (or (%box-structure-immutable? obj) (%box-procedure-immutable? obj)))
212
213(define (box-mutable? obj) (or (%box-structure-mutable? obj) (%box-procedure-mutable? obj)))
214
215;; Mutators
216
217(define (box-set! box val)
218  (cond ((%box-structure-tag box) =>
219         (lambda (tag)
220           (case tag
221             ((box!) (%box-structure-set! box val))
222             ((box)  (%box-immutable-error 'box-set! box val)))))
223        ((%box-procedure-tag box) =>
224         (lambda (tag)
225           (case tag
226             ((boxvar! boxloc!) (%box-procedure-set! box val))
227             ((boxvar boxloc)   (%box-immutable-error 'box-set! box val)))))
228        (else
229         (%box-type-error 'box-set! box val))))
230
231;; Assessors
232
233(define box-ref
234  (getter-with-setter
235    (lambda (box)
236      (cond ((%box-structure? box)  (%box-structure-ref box))
237            ((%box-procedure? box)  (%box-procedure-ref box))
238            (else                   (%box-type-error 'box-ref box))))
239    box-set!))
240
241(define (box-location box #!optional (weak? #f))
242  (cond ((%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1))
243        ((%box-procedure? box)   (box (lambda (ref set loc) (loc))))
244        (else                    (%box-type-error 'box-location box))))
245
246
247;;; MZ Scheme Style
248
249(define-syntax box
250  (syntax-rules ()
251    ((_ ?arg0 ...) (make-box ?arg0 ...))))
252
253(define-syntax unbox
254  (syntax-rules ()
255    ((_ ?box) (box-ref ?box))))
256
257(define-syntax set-box!
258  (syntax-rules ()
259    ((_ ?box ?val) (box-set! ?box ?val))))
260
261
262;;; Read/Print Syntax
263
264(set-sharp-read-syntax! #\& (lambda (p) (make-box (read p))))
265
266(define-reader-ctor 'box make-box)
267
268(define-record-printer (box x p) (with-output-to-port p (lambda () (%box-print x))))
269
270(define-record-printer (box-immutable x p) (with-output-to-port p (lambda () (%box-print x))))
271
272(set! ##sys#procedure->string
273  (let ((##sys#procedure->string ##sys#procedure->string))
274    (lambda (x)
275                        (if (%box? x) (with-output-to-string (lambda () (%box-print x)))
276                                        (##sys#procedure->string x)))))
277
278) ;module box
Note: See TracBrowser for help on using the repository browser.