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

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

Save

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