source: project/release/4/srfi-45/trunk/srfi-45.scm @ 14152

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

Testing of SRFI 45 `delay'. Better (?) re-fetch handling.

File size: 6.4 KB
Line 
1;;;; srfi-45.scm
2;;;; Kon Lovett, May '09
3
4;; Issues
5;;
6;; - All operations inlined & primitive due to high-performance nature.
7;;
8;; - This has been heavily modified from the original in order to extend
9;; rather than supplant the R5RS 'delay'.
10
11;;; Prelude
12
13(declare
14  (usual-integrations)
15  (disable-interrupts)
16  (fixnum)
17  (local)
18  (inline)
19  (no-procedure-checks)
20  (bound-to-procedure
21    ##sys#signal-hook))
22
23(include "chicken-primitive-object-inlines")
24
25;; Recursive promise
26
27(define-inline (%make-promise-box tag val) (%cons tag val))
28(define-inline (%promise-box? obj) (%pair? obj))
29(define-inline (%promise-box-tag prm) (%car prm))
30(define-inline (%promise-box-value prm) (%cdr prm))
31(define-inline (%promise-box-tag-set! prm tag) (%set-car!/mutate prm tag))
32(define-inline (%promise-box-value-set! prm val) (%set-cdr! prm val))
33
34(define-inline (%make-promise tag val) (make-box (%make-promise-box tag val)))
35(define-inline (%promise-box-ref prmbox) (*box-structure-ref prmbox))
36(define-inline (%promise-box-set! box prmbox) (*box-structure-set! box prmbox))
37
38(define-inline (%promise-box?->promise-box obj)
39  (and (*box-structure? obj)
40       (let ((boxed (%promise-box-ref obj)))
41         (and (%promise-box? boxed)
42              boxed ) ) ) )
43
44(define-inline (%lazy-promise? obj)
45  (and-let* ((boxed (%promise-box?->promise-box obj)))
46    (%eq? lazy-tag (%promise-box-tag boxed))) )
47
48(define-inline (%eager-promise? obj)
49  (and-let* ((boxed (%promise-box?->promise-box obj)))
50    (%eq? eager-tag (%promise-box-tag boxed) ) ) )
51
52(define-inline (%promise? obj)
53  (and-let* ((boxed (%promise-box?->promise-box obj)))
54    (let ((tag (%promise-box-tag boxed)))
55      (or (%eq? lazy-tag tag) (%eq? eager-tag tag) ) ) ) )
56
57(define-inline (%lazy-thunk? obj)
58  (and-let* ((dat (procedure-data obj)))
59    (%eq? thunk-tag dat) ) )
60
61;;; Module srfi-45
62
63(require-library box)
64
65(module srfi-45 (;export
66  ; SRFI 45
67  (lazy $finlzy)
68  eager
69  promise?
70  #;delay ;R5RS supported
71  force
72  ; Extras
73  lazy-promise?
74  eager-promise?
75  recursive-promise?)
76
77(import (rename scheme (force r5rs:force) #;(delay r5rs:delay))
78        (rename chicken (promise? r5rs:promise?))
79        (only lolevel procedure-data extend-procedure)
80        (only box make-box *box-structure? *box-structure-ref *box-structure-set!))
81
82;; Errors
83
84(define (error-promise-corrupt loc prm)
85  (##sys#signal-hook #:type-error loc "promise is corrupt" prm) )
86
87;; Unique Ids
88
89(define lazy-tag (%make-unique-object 'lazy))
90(define eager-tag (%make-unique-object 'eager))
91(define thunk-tag (%make-unique-object 'thunk))
92
93;; Helpers
94
95(define ($finlzy thunk) (%make-promise lazy-tag (extend-procedure thunk thunk-tag)))
96
97;; Constructors
98
99(define-syntax lazy
100  (syntax-rules ()
101    ((_ ?expr) ($finlzy (lambda () ?expr)) ) ) )
102
103(define (eager value) (%make-promise eager-tag #;value (list value)))
104
105#; ;R5RS supported
106(define-syntax delay
107  (syntax-rules ()
108    ((_ ?exp) (lazy (eager ?exp)) ) ) )
109
110;; Predicates
111
112(define (lazy-promise? obj) (%lazy-promise? obj))
113(define (eager-promise? obj) (%eager-promise? obj))
114(define (recursive-promise? obj) (%promise? obj))
115(define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))
116
117;; Force
118
119(define (force top)
120
121  ; What kind of promise?
122  (cond
123
124    ; New fashion promise?
125    ((%promise? top)
126
127     ; Unbox
128     (let* ((top-box (%promise-box-ref top))
129            (value (%promise-box-value top-box)))
130
131       ; Process by kind
132       (select (%promise-box-tag top-box)
133
134         ; Eager has value ready
135         ((eager-tag) #;value (apply values value))
136
137         ; Force a lazy promise's value
138         ((lazy-tag)
139          (cond
140
141            ; Actual lazy promise?
142            ((%lazy-thunk? value)
143
144             ; Force the promise by invoking the thunk
145             (let ((value* (receive (value))))
146
147               ; Re-fetch and check the top promise again in case it recursed into `force'
148               (let ((top-box (%promise-box-ref top)))
149
150                 ; Eager, lazy, r5rs or actual results
151                 (when (%eq? lazy-tag (%promise-box-tag top-box))
152
153                   ; Another promise?
154                   (let ((value1 (and (= 1 (length value*)) (%car value*))))
155
156                     (cond ((not value1)
157                            (%promise-box-value-set! top-box value*) )
158
159                           ((%lazy-promise? value1)
160
161                            ; Copy the enclosed promise to the top
162                            (let ((promise-box (%promise-box-ref value1)))
163                               (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
164                               (%promise-box-value-set! top-box (%promise-box-value promise-box))
165                               (%promise-box-set! value1 top-box) ) )
166
167                           (else
168                            (%promise-box-value-set! top-box value1) ) ) ) )
169
170                 ; Now that all the work has been done, return a result
171                 (force top) ) ) )
172
173            ; Wrapped promise?
174            ((or (%eager-promise? value) (r5rs:promise? value)) (force value))
175
176            ; Already "forced"
177            (else #;value (apply values value) ) ) )
178
179         ; This shouldn't happen
180         (else
181          (error-promise-corrupt 'force top) ) ) ) )
182
183    ; Old fashion promise?
184    ((r5rs:promise? top) (r5rs:force top) )
185
186    ; No promise at all. Return object per the Chicken manual.
187    (else
188     top ) ) )
189
190;;;
191
192(register-feature! 'srfi-45)
193
194) ;module srfi-45
195
196#|
197Copyright (C) AndrŽ van Tonder (2003). All Rights Reserved.
198
199
200Permission is hereby granted, free of charge, to any person obtaining a
201copy of this software and associated documentation files (the
202"Software"), to deal in the Software without restriction, including
203without limitation the rights to use, copy, modify, merge, publish,
204distribute, sublicense, and/or sell copies of the Software, and to
205permit persons to whom the Software is furnished to do so, subject to
206the following conditions:
207
208
209The above copyright notice and this permission notice shall be included
210in all copies or substantial portions of the Software.
211
212
213THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
214OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
215MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
216IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
217CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
218TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
219SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
220|#
Note: See TracBrowser for help on using the repository browser.