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

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

Use of "check-errors", fix for use of R5RS promise with a lazy promise.

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