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

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

Own boxing.

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