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

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

Canon dir struct

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(use box)
40
41(eval-when (compile)
42  (declare
43    (usual-integrations)
44    (inline)
45    (export
46      lazy-promise?
47      eager-promise?
48      recursive-promise?
49      standard-promise?
50      promise?
51      standard-force
52      force) ) )
53
54;;; Originals
55
56(define standard-promise? promise?)
57
58(define standard-force force)
59
60;;; Predicates
61
62(define (lazy-promise? obj)
63  (and (box? obj)
64    (let ([boxed (box-ref obj)])
65      (and (pair? boxed) (eq? 'lazy (car boxed))))) )
66
67(define (eager-promise? obj)
68  (and (box? obj)
69    (let ([boxed (box-ref obj)])
70      (and (pair? boxed) (eq? 'eager (car boxed))))) )
71
72(define (recursive-promise? obj)
73  (or (lazy-promise? obj) (eager-promise? obj)) )
74
75(define (promise? obj)
76  (or (standard-promise? obj) (recursive-promise? obj)) )
77
78;;; The guts
79
80(define (force obj)
81  (if (box? obj)
82      ; then must be a recursive-promise
83      (let ([content (box-ref obj)])
84        (if (pair? content)
85            (let ([value (cdr content)])
86              (switch (car content)
87                ['eager
88                  value]
89                ['lazy
90                  (cond [(standard-promise? value)  ; Wrapped baseline promise
91                          (standard-force value)]
92                        [(procedure? value)         ; Actual lazy promise
93                          (let ([*promise (value)])
94                            ; Re-fetch and check the original promise in case
95                            ; the first line of the let caused it to be forced.
96                            (let ([content (box-ref obj)])
97                              ; Only propagate lazy promises
98                              (unless (eq? (car content) 'eager)
99                                (if (box? *promise)
100                                    ; then a recursive-promise
101                                    (let ([*content (box-ref *promise)])
102                                      (set-car! content (car *content))
103                                      (set-cdr! content (cdr *content))
104                                      (box-set! *promise content))
105                                    ; else a standard-promise
106                                    (set-cdr! content *promise)))))
107                          ; Now that all the work has been done, return a result
108                          (force obj)]
109                        [else                       ; Already "forced"
110                          value])]
111                [else
112                  (error 'force "unknown promise" obj)]))
113            (error 'force "unknown promise" obj)))
114      ; else must be a standard-promise
115      (standard-force obj)) )
Note: See TracBrowser for help on using the repository browser.