source: project/release/3/srfi-45/trunk/srfi-45-support.scm @ 10025

Last change on this file since 10025 was 10025, checked in by Kon Lovett, 13 years ago

Register feature

File size: 3.9 KB
Line 
1;;;; srfi-45-support.scm
2;;;; Kon Lovett, May '06
3
4;; Issues
5;;
6;; - This has been heavily modified from the original in order to extend
7;; rather than supplant the R6RS 'delay'.
8;;
9;; - 'eager' is now a macro.
10;;
11;; - Re-defines 'force' & 'promise?'.
12
13#|
14Copyright (C) AndrŽ van Tonder (2003). All Rights Reserved.
15
16
17Permission is hereby granted, free of charge, to any person obtaining a
18copy of this software and associated documentation files (the
19"Software"), to deal in the Software without restriction, including
20without limitation the rights to use, copy, modify, merge, publish,
21distribute, sublicense, and/or sell copies of the Software, and to
22permit persons to whom the Software is furnished to do so, subject to
23the following conditions:
24
25
26The above copyright notice and this permission notice shall be included
27in all copies or substantial portions of the Software.
28
29
30THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
31OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
32MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
33IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
34CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
35TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
36SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
37|#
38
39(eval-when (compile)
40  (declare
41    (usual-integrations)
42    (inline)
43    (export
44      lazy-promise?
45      eager-promise?
46      recursive-promise?
47      standard-promise?
48      promise?
49      standard-force
50      force) ) )
51
52(use box)
53
54(register-feature 'srfi-45)
55
56;;; Originals
57
58(define standard-promise? promise?)
59
60(define standard-force force)
61
62;;; Predicates
63
64(define (lazy-promise? obj)
65  (and (box? obj)
66    (let ([boxed (box-ref obj)])
67      (and (pair? boxed) (eq? 'lazy (car boxed))))) )
68
69(define (eager-promise? obj)
70  (and (box? obj)
71    (let ([boxed (box-ref obj)])
72      (and (pair? boxed) (eq? 'eager (car boxed))))) )
73
74(define (recursive-promise? obj)
75  (or (lazy-promise? obj) (eager-promise? obj)) )
76
77(define (promise? obj)
78  (or (standard-promise? obj) (recursive-promise? obj)) )
79
80;;; The guts
81
82(define (force obj)
83  (if (box? obj)
84      ; then must be a recursive-promise
85      (let ([content (box-ref obj)])
86        (if (pair? content)
87            (let ([value (cdr content)])
88              (switch (car content)
89                ['eager
90                  value]
91                ['lazy
92                  (cond [(standard-promise? value)  ; Wrapped baseline promise
93                          (standard-force value)]
94                        [(procedure? value)         ; Actual lazy promise
95                          (let ([*promise (value)])
96                            ; Re-fetch and check the original promise in case
97                            ; the first line of the let caused it to be forced.
98                            (let ([content (box-ref obj)])
99                              ; Only propagate lazy promises
100                              (unless (eq? (car content) 'eager)
101                                (if (box? *promise)
102                                    ; then a recursive-promise
103                                    (let ([*content (box-ref *promise)])
104                                      (set-car! content (car *content))
105                                      (set-cdr! content (cdr *content))
106                                      (box-set! *promise content))
107                                    ; else a standard-promise
108                                    (set-cdr! content *promise)))))
109                          ; Now that all the work has been done, return a result
110                          (force obj)]
111                        [else                       ; Already "forced"
112                          value])]
113                [else
114                  (error 'force "unknown promise" obj)]))
115            (error 'force "unknown promise" obj)))
116      ; else must be a standard-promise
117      (standard-force obj)) )
Note: See TracBrowser for help on using the repository browser.