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

Last change on this file since 12290 was 12290, checked in by Kon Lovett, 12 years ago

Save.

File size: 6.2 KB
Line 
1;;;; box.scm
2;;;; Kon Lovett, Oct '08
3
4(declare
5  (usual-integrations)
6  (fixnum)
7  (inline)
8  ; ##sys#procedure->string is redefined!
9  (disable-warning redef)
10  (import
11    ##sys#procedure->string)
12  (bound-to-procedure
13    ##sys#procedure->string) )
14
15(cond-expand
16  ( paranoia )
17  ( else
18    (declare
19      (no-procedure-checks)
20      (no-bound-checks) ) ) )
21
22;;;
23
24(module box
25  (make-box make-box-variable make-box-location
26   box? box-variable? box-location?
27   box-mutable? box-immutable?
28   box-set! box-ref
29   box-location
30   box
31   set-box! unbox)
32
33(import scheme)
34(import (only chicken abort make-property-condition make-composite-condition set-sharp-read-syntax!))
35(import (only lolevel extend-procedure procedure-data record-instance? make-record-instance))
36
37;;
38
39(define (%record-tag rec)
40  (##sys#slot rec 0) )
41
42(define (%record-slot-set! rec idx obj)
43  (##sys#setslot rec idx obj) )
44
45(define (%record-slot-ref rec idx)
46  (##sys#slot rec idx) )
47
48;;
49
50(define-syntax make-box-variable
51  (syntax-rules (#:immutable)
52    ( (_ ?var)
53      #;(identifier? ?var)
54      (box:finvar (lambda () ?var)
55                  (lambda (value) (set! ?var value))) )
56    ( (_ ?var #:immutable #f)
57      #;(identifier? ?var)
58      (box:finvar (lambda () ?var)
59                  (lambda (value) (set! ?var value))) )
60    ( (_ ?var #:immutable #t)
61      #;(identifier? ?var)
62      (box:finvar (lambda () ?var)
63                  box:immutable-set) ) ) )
64
65(define-syntax make-box-location
66  (syntax-rules (#:immutable)
67    ( (_ ?typ ?val)
68      #;(identifier? ?typ)
69      (let-location ( (var ?typ ?val) )
70        (box:finloc (lambda () var)
71                    (lambda (value) (set! var value))
72                    (lambda () (location var))) ) )
73    ( (_ ?typ ?val #:immutable #f)
74      #;(identifier? ?typ)
75      (let-location ( (var ?typ ?val) )
76        (box:finloc (lambda () var)
77                    (lambda (value) (set! var value))
78                    (lambda () (location var))) ) )
79    ( (_ ?typ ?val #:immutable #t)
80      #;(identifier? ?typ)
81      (let-location ( (var ?typ ?val) )
82        (box:finloc (lambda () var)
83                    box:immutable-set
84                                                                          (lambda () (location var))) ) ) ) )
85
86;;
87
88(define-syntax box
89  (syntax-rules ()
90    ( (_ ?arg0 ...)
91      (make-box ?arg0 ...) ) ) )
92
93(define-syntax unbox
94  (syntax-rules ()
95    ( (_ ?box)
96      (box-ref ?box) ) ) )
97
98(define-syntax set-box!
99  (syntax-rules ()
100    ( (_ ?box ?value)
101      (box-set! ?box ?value) ) ) )
102
103;;
104
105(define (make-exn-condition loc msg args)
106  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
107
108(define (make-box-condition box)
109  (make-property-condition 'box 'box box) )
110
111(define (make-exn-box-condition loc msg box args)
112  (make-composite-condition
113    (make-exn-condition loc msg args)
114    (make-box-condition box)) )
115
116(define (box-location-error loc box . args)
117  (abort (make-exn-box-condition loc "cannot take location of box" box args)) )
118
119(define (box-immutable-error loc box . args)
120  (abort (make-exn-box-condition loc "cannot set immutable box" box args)) )
121
122(define (box-check-error loc box . args)
123  (abort (make-exn-box-condition loc "not a box" box args)) )
124
125;;
126
127(define (box:immutable-set value)
128        (box-immutable-error 'box-set! '#<box> value) )
129
130(define (box:finvar ref set)
131  (extend-procedure
132        (lambda (proc)
133                (proc ref set (lambda () (location (ref)))))
134        'box-reference) )
135
136(define (box:finloc ref set loc)
137  (extend-procedure
138        (lambda (proc)
139                (proc ref set loc))
140        'box-reference) )
141
142(define (check-box loc obj)
143  (unless (box? obj)
144    (box-check-error loc obj) ) )
145
146;;
147
148(define (make-box init #!key (immutable #f) (location #f))
149  (if location
150      (extend-procedure
151        (let ( (boxed init) )
152          (lambda (proc)
153            (proc (lambda () boxed)                         ; ref
154                  (if immutable                             ; set!
155                      box:immutable-set
156                      (lambda (value) (set! boxed value)) )
157                  (lambda () (location boxed))) ) )         ; loc
158          'box)
159      (if immutable
160          (make-record-instance 'box-immutable init)
161          (make-record-instance 'box init) ) ) )
162
163;;
164
165(define (box-structure? obj)
166  (and (record-instance? obj)
167       (let ( (tag (%record-tag obj)) )
168         (or (eq? 'box tag) (eq? 'box-immutable tag)) ) ) )
169
170(define (box-procedure? obj)
171  ; 'procedure-data' returns #f for anything other than an extended-procedure!
172  (and-let* ( (tag (procedure-data obj)) )
173                (or (eq? 'box tag) (eq? 'box-reference tag) ) ) )
174
175;;
176
177(define (box? obj)
178  (or (box-structure? obj) (box-procedure? obj) ) )
179
180(define (box-variable? obj)
181  ; 'procedure-data' returns #f for anything other than an extended-procedure!
182  (eq? 'box-reference (procedure-data obj)) )
183
184(define (box-immutable? obj)
185  (or (and (box-structure? obj)
186                     (eq? 'box-immutable (%record-tag obj)) )
187      (and (box-procedure? obj)
188           (obj (lambda (ref set loc) (eq? box:immutable-set set))) ) ) )
189
190(define (box-mutable? obj)
191        (not (box-immutable obj)) )
192
193;;
194
195(define (box-set! box value)
196  (cond
197    ( (record-instance? box)
198      (case (%record-tag obj)
199        ( (box)
200          (%record-slot-set! box 1 value) )
201        ( (box-immutable)
202          (box-immutable-error 'box-set! box value) )
203        ( else
204          (box-check-error 'box-set! box value) ) ) )
205    ( (box-procedure? box)
206      (box (lambda (ref set loc) (set value))) )
207    ( else
208      (box-check-error 'box-set! box value) ) ) )
209
210(define (box-ref box)
211  (cond
212    ( (box-structure? box)
213      (%record-slot-ref box 1) )
214    ( (box-procedure? box)
215      (box (lambda (ref set loc) (ref))) )
216    ( else
217      (box-check-error 'box-ref box) ) ) )
218
219(define (box-location box #!key (weak #f))
220  (cond
221    ( (box-structure? box)
222      ((if weak make-weak-locative make-locative) box 1)
223    ( (box-procedure? box)
224      (box (lambda (ref set loc) (loc))) )
225    ( else
226      (box-check-error 'box-location box) ) ) )
227
228;;
229
230(define (box-print box)
231        (display "#&") (write (box-ref box)) )
232
233;;; Initialize
234
235(set-sharp-read-syntax! #\&
236  (lambda (port)
237    (make-box (read port))))
238
239(set! ##sys#procedure->string
240  (let ( (##sys#procedure->string ##sys#procedure->string) )
241    (lambda (x)
242                        (if (box? x)
243                                        (with-output-to-string (lambda () (box-print x)))
244                                        (##sys#procedure->string x) ) ) ) )
245
246)
Note: See TracBrowser for help on using the repository browser.