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

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

Pre-release

File size: 5.3 KB
Line 
1;;;; box.scm
2;;;; Kon Lovett, Oct '08
3
4;; Issues
5;;
6;; - Use of "chicken-primitive-object-inlines" '%foo' routines is not meant as an
7;; endorsement.
8
9(declare
10  (usual-integrations)
11  (fixnum)
12  (inline)
13  (local)
14  ; ##sys#procedure->string is redefined!
15  (disable-warning redef)
16  (bound-to-procedure
17    ##sys#signal-hook
18    ##sys#procedure->string)
19  (no-procedure-checks)
20  (no-bound-checks) )
21
22;;; Prelude
23
24(include "chicken-primitive-object-inlines")
25
26(require-library ports lolevel)
27
28;; Helpers
29
30(define-inline (box-structure? obj)
31  (or (%structure-instance? obj 'box)
32      (%structure-instance? obj 'box-immutable)) )
33
34(define-inline (box-procedure? obj)
35  ; 'procedure-data' returns #f for anything other than an extended-procedure!
36  (and-let* ([tag (procedure-data obj)])
37                (or (%eq? 'box-variable tag)
38                    (%eq? 'box-location tag)) ) )
39
40(define-inline (box-setter box)
41  (box (lambda (ref set loc) set)) )
42
43(define-inline (box-immutable-setter? setter)
44  (%undefined? setter) )
45
46(define-inline (box-print box)
47        (display "#&") (write (box-ref box)) )
48
49;;; Module box
50
51(module box (
52  make-box (make-box-variable finvar) (make-box-location finloc)
53  box? box-variable? box-location?
54  box-mutable? box-immutable?
55  box-set! box-ref
56  box-location
57  box
58  set-box! unbox)
59
60(import
61  scheme
62  (only chicken
63    define-record-printer
64    let-location
65    and-let*
66    getter-with-setter
67    void
68    set-sharp-read-syntax!
69    ##sys#signal-hook
70    ##sys#procedure->string)
71  (only ports
72    with-output-to-port
73    with-output-to-string)
74  (only lolevel
75    extend-procedure procedure-data
76    make-weak-locative make-locative) )
77
78;;; Internals
79
80;; Errors
81
82(define (box-immutable-error loc box . args)
83  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args) )
84
85(define (box-type-error loc obj . args)
86  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args) )
87
88;; Finishers
89
90(define (finvar ref set)
91  (extend-procedure
92        (lambda (proc)
93                (proc ref set (lambda () (location (ref)))))
94        'box-variable) )
95
96(define (finloc ref set loc)
97  (extend-procedure
98        (lambda (proc)
99                (proc ref set loc))
100        'box-location) )
101
102;;; Globals
103
104;; Constructers
105
106(define-syntax make-box-variable
107  (syntax-rules (#:immutable?)
108    [(_ ?var)
109      (make-box-variable ?var #:immutable? #f) ]
110    [(_ ?var #:immutable? ?flg)
111      #;(identifier? ?var)
112      (finvar
113        (lambda () ?var)
114        (if ?flg (void) (lambda (value) (set! ?var value)))) ] ) )
115
116(define-syntax make-box-location
117  (syntax-rules (#:immutable?)
118    [(_ ?typ ?val)
119      (make-box-location ?typ ?val #:immutable? #f) ]
120    [(_ ?typ ?val #:immutable? ?flg)
121      #;(identifier? ?typ)
122      (let-location ([var ?typ ?val])
123        (finloc
124          (lambda () var)
125          (if ?flg (void) (lambda (value) (set! var value)))
126          (lambda () (location var))) ) ] ) )
127
128(define (make-box init #!key (immutable? #f))
129  (%make-structure (if immutable? 'box-immutable 'box) init) )
130
131;; Predicates
132
133(define (box? obj)
134  (or (box-structure? obj)
135      (box-procedure? obj)) )
136
137(define (box-variable? obj)
138  (and-let* ([tag (procedure-data obj)])
139                (%eq? 'box-variable tag) ) )
140
141(define (box-location? obj)
142  (and-let* ([tag (procedure-data obj)])
143                (%eq? 'box-location tag) ) )
144
145(define (box-immutable? obj)
146  (or (%structure-instance? obj 'box-immutable)
147      (and (box-procedure? obj)
148           (box-immutable-setter? (box-setter obj)) ) ) )
149
150(define (box-mutable? obj)
151        (not (box-immutable? obj)) )
152
153;; Assessors
154
155(define (box-set! box value)
156  (cond
157    [(%generic-structure? box)
158      (case (%structure-tag box)
159        [(box)
160          (%structure-set! box 1 value) ]
161        [(box-immutable)
162          (box-immutable-error 'box-set! box value) ]
163        [else
164          (box-type-error 'box-set! box value) ] ) ]
165    [(box-procedure? box)
166      (let ([setter (box-setter box)])
167        (if (box-immutable-setter? setter)
168            (box-immutable-error 'box-set! box value)
169            (setter value) ) ) ]
170    [else
171      (box-type-error 'box-set! box value) ] ) )
172
173(define box-ref
174  (getter-with-setter
175    (lambda (box)
176      (cond
177        [(box-structure? box)
178          (%structure-ref box 1) ]
179        [(box-procedure? box)
180          (box (lambda (ref set loc) (ref))) ]
181        [else
182          (box-type-error 'box-ref box) ] ) )
183    box-set! ) )
184
185(define (box-location box #!key (weak? #f))
186  (cond
187    [(box-structure? box)
188      ((if weak? make-weak-locative make-locative) box 1) ]
189    [(box-procedure? box)
190      (box (lambda (ref set loc) (loc))) ]
191    [else
192      (box-type-error 'box-location box) ] ) )
193
194;; MZ Scheme Style
195
196(define-syntax box
197  (syntax-rules ()
198    [(_ ?arg0 ...)  (make-box ?arg0 ...) ] ) )
199
200(define-syntax unbox
201  (syntax-rules ()
202    [(_ ?box) (box-ref ?box) ] ) )
203
204(define-syntax set-box!
205  (syntax-rules ()
206    [(_ ?box ?value)  (box-set! ?box ?value) ] ) )
207
208;;; Read/Print Syntax
209
210(set-sharp-read-syntax! #\&
211  (lambda (port)
212    (make-box (read port))))
213
214(define-record-printer (box x out)
215  (with-output-to-port out (lambda () (box-print x))) )
216
217(define-record-printer (box-immutable x out)
218  (with-output-to-port out (lambda () (box-print x))) )
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) ;module box
Note: See TracBrowser for help on using the repository browser.