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

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

Fixed -inline use.

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