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

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

Experimental.

File size: 6.3 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)
56          (%eq? eager-tag tag) ) ) ) )
57
58(define-inline (%lazy-thunk? obj)
59  (and-let* ((dat (procedure-data obj)))
60    (%eq? thunk-tag dat) ) )
61
62;;; Module srfi-45
63
64(require-library box)
65
66(module srfi-45 (;export
67  ; SRFI 45
68  (lazy $finlzy)
69  eager
70  promise?
71  force
72  ; Extras
73  lazy-promise?
74  eager-promise?
75  recursive-promise?)
76
77(import (rename scheme (force r5rs:force))
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)
102     ($finlzy (lambda () ?expr)) ) ) )
103
104(define (eager value) (%make-promise eager-tag (list value)))
105
106;; Predicates
107
108(define (lazy-promise? obj) (%lazy-promise? obj))
109(define (eager-promise? obj) (%eager-promise? obj))
110(define (recursive-promise? obj) (%promise? obj))
111(define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))
112
113;; Force
114
115(define (force top)
116
117  ; What kind of promise?
118  (cond
119
120    ; New fashion promise?
121    ((%promise? top)
122
123     ; Unbox
124     (let* ((top-box (%promise-box-ref top))
125            (value (%promise-box-value top-box)))
126
127       ; Process by kind
128       (select (%promise-box-tag top-box)
129
130         ; Eager has value ready
131         ((eager-tag) (apply values value))
132
133         ; Force a lazy promise's value
134         ((lazy-tag)
135          (cond
136
137            ; Wrapped r5rs promise?
138            ((r5rs:promise? value) (r5rs:force value))
139
140            ; Actual lazy promise?
141            ((%lazy-thunk? value)
142
143             ; Force the promise by invoking the thunk
144             (let ((value* (receive (value))))
145
146               ; Re-fetch and check the top promise again in case it recursed into `force'
147               (let ((top-box (%promise-box-ref top)))
148
149                 ; Eager, lazy, r5rs or actual results
150                 (unless (%eq? eager-tag (%promise-box-tag top-box))
151
152                   ; Try a promise
153                   (let ((promise (and (not (%null? value*))
154                                       (%null? (%cdr value*))
155                                       (%car value*))))
156                     (if (%lazy-promise? promise)
157
158                         ; then lazy promise
159                         (let ((promise-box (%promise-box-ref promise)))
160                            ; Copy the enclosed promise to the top
161                            (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
162                            (%promise-box-value-set! top-box (%promise-box-value promise-box))
163                            (%promise-box-set! promise top-box) )
164
165                         ; else results or a R5RS promise
166                         (%promise-box-value-set! top-box promise) ) ) )
167
168                 ; Now that all the work has been done, return a result
169                 (force top) ) ) )
170
171            ; Already "forced"
172            (else (apply values value) ) ) )
173
174         ; This shouldn't happen
175         (else
176          (error-promise-corrupt 'force top) ) ) ) )
177
178    ; Old fashion promise?
179    ((r5rs:promise? top) (r5rs:force top) )
180
181    ; No promise at all. Return object per the Chicken manual.
182    (else
183     top ) ) )
184
185;;;
186
187(register-feature! 'srfi-45)
188
189) ;module srfi-45
190
191#|
192Copyright (C) AndrŽ van Tonder (2003). All Rights Reserved.
193
194
195Permission is hereby granted, free of charge, to any person obtaining a
196copy of this software and associated documentation files (the
197"Software"), to deal in the Software without restriction, including
198without limitation the rights to use, copy, modify, merge, publish,
199distribute, sublicense, and/or sell copies of the Software, and to
200permit persons to whom the Software is furnished to do so, subject to
201the following conditions:
202
203
204The above copyright notice and this permission notice shall be included
205in all copies or substantial portions of the Software.
206
207
208THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
209OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
210MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
211IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
212CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
213TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
214SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
215|#
Note: See TracBrowser for help on using the repository browser.