source: project/release/4/srfi-45/tags/3.0.0/srfi-45.scm @ 15605

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

Rel 3.0.0 - Redefines 'delay'

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