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

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