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

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

Removed use of box.

File size: 5.2 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 tag val) (%make-structure tag val))
28
29(define-inline (%eager-promise? obj) (%structure-instance? obj 'eager-promise))
30(define-inline (%lazy-promise? obj) (%structure-instance? obj 'lazy-promise))
31(define-inline (%promise? obj) (or (%eager-promise? obj) (%lazy-promise? obj)))
32(define-inline (%lazy-thunk? obj) (and-let* ((dat (procedure-data obj))) (%eq? thunk-tag dat)))
33
34(define-inline (%promise-tag prm) (%structure-ref prm 0))
35(define-inline (%promise-tag-set! prm tag) (%structure-set!/immediate prm 0 tag))
36
37(define-inline (%promise-value prm) (%structure-ref prm 1))
38(define-inline (%promise-value-set! prm prmbox) (%structure-set! prm 1 prmbox))
39
40(define-inline (%promise-set! prm prm2)
41  (%promise-tag-set! prm (%promise-tag prm2))
42  (%promise-value-set! prm (%promise-value prm2)) )
43
44;;; Module srfi-45
45
46(module srfi-45 (;export
47  ; SRFI 45
48  (lazy $finlzy$)
49  eager
50  promise?
51  #;delay ;R5RS supported
52  force
53  ; Extras
54  lazy-promise?
55  eager-promise?
56  recursive-promise?)
57
58(import (rename scheme (force r5rs:force) #;(delay r5rs:delay))
59        (rename chicken (promise? r5rs:promise?))
60        (only lolevel procedure-data extend-procedure))
61
62(require-library lolevel)
63
64;; Errors
65
66(define (error-promise-corrupt loc prm)
67  (##sys#signal-hook #:type-error loc "promise is corrupt" prm) )
68
69;; Unique Ids
70
71(define thunk-tag (%make-unique-object 'thunk))
72
73;; Helpers
74
75(define ($finlzy$ thunk) (%make-promise 'lazy-promise (extend-procedure thunk thunk-tag)))
76
77;; Constructors
78
79(define-syntax lazy
80  (syntax-rules ()
81    ((_ ?expr) ($finlzy$ (lambda () ?expr)) ) ) )
82
83(define (eager value) (%make-promise 'eager-promise (list value)))
84
85#; ;R5RS supported
86(define-syntax delay
87  (syntax-rules ()
88    ((_ ?exp) (lazy (eager ?exp)) ) ) )
89
90;; Predicates
91
92(define (lazy-promise? obj) (%lazy-promise? obj))
93(define (eager-promise? obj) (%eager-promise? obj))
94(define (recursive-promise? obj) (%promise? obj))
95(define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))
96
97;; Force
98
99(define (force top)
100  ; What kind of promise?
101  (cond
102    ; New fashion promise?
103    ((%promise? top)
104      ; Unbox
105      (let ((value (%promise-value top)))
106        ; Process by kind
107        (case (%promise-tag top)
108          ; Eager has value ready
109          ((eager-promise)
110            (apply values value))
111          ; Force a lazy promise's value
112          ((lazy-promise)
113            ; Better be an un-evaluated thunk
114            (if (%lazy-thunk? value)
115                ; Force the promise by invoking the thunk
116                ; Re-fetch and check the top promise again in case it recursed into `force'
117                (let ((value* (receive (value))))
118                  ;
119                  (unless (%eq? 'eager-promise (%promise-tag top))
120                    ; Another promise?
121                    (let ((promise (and (= 1 (length value*)) (%car value*))))
122                      (if promise
123                          ; then copy the promise to the top
124                          (%promise-set! top promise)
125                          ; else this shouldn't happen
126                          (error 'force "expected a promise" value*) ) ) )
127                   ; Now that all the work has been done, return a result
128                   (force top) )
129                ; else this shouldn't happen
130                (error 'force "expected an un-forced lazy promise" value) ) )
131          ; This shouldn't happen
132          (else
133            (error-promise-corrupt 'force top) ) ) ) )
134    ; Old fashion promise?
135    ((r5rs:promise? top)
136      (r5rs:force top) )
137    ; No promise at all. Return object per the Chicken manual.
138    (else
139      top ) ) )
140
141;;;
142
143(register-feature! 'srfi-45)
144
145) ;module srfi-45
146
147#|
148Copyright (C) AndrŽ van Tonder (2003). All Rights Reserved.
149
150
151Permission is hereby granted, free of charge, to any person obtaining a
152copy of this software and associated documentation files (the
153"Software"), to deal in the Software without restriction, including
154without limitation the rights to use, copy, modify, merge, publish,
155distribute, sublicense, and/or sell copies of the Software, and to
156permit persons to whom the Software is furnished to do so, subject to
157the following conditions:
158
159
160The above copyright notice and this permission notice shall be included
161in all copies or substantial portions of the Software.
162
163
164THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
165OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
166MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
167IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
168CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
169TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
170SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
171|#
Note: See TracBrowser for help on using the repository browser.