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

Last change on this file since 12265 was 12265, checked in by Kon Lovett, 13 years ago

Save.

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