Commit | Line | Data |
---|---|---|
f16a2007 AR |
1 | ;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms |
2 | ||
d291d799 | 3 | ;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. |
f16a2007 AR |
4 | ;; Copyright (C) 2003 André van Tonder. All Rights Reserved. |
5 | ||
6 | ;; Permission is hereby granted, free of charge, to any person | |
7 | ;; obtaining a copy of this software and associated documentation | |
8 | ;; files (the "Software"), to deal in the Software without | |
9 | ;; restriction, including without limitation the rights to use, copy, | |
10 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies | |
11 | ;; of the Software, and to permit persons to whom the Software is | |
12 | ;; furnished to do so, subject to the following conditions: | |
13 | ||
14 | ;; The above copyright notice and this permission notice shall be | |
15 | ;; included in all copies or substantial portions of the Software. | |
16 | ||
17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
18 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
19 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
20 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS | |
21 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN | |
22 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN | |
23 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | |
24 | ;; SOFTWARE. | |
25 | ||
26 | ;;; Commentary: | |
27 | ||
d291d799 MW |
28 | ;; This is the code of the reference implementation of SRFI-45, modified |
29 | ;; to use SRFI-9 and to add 'promise?' to the list of exports. | |
f16a2007 AR |
30 | |
31 | ;; This module is documented in the Guile Reference Manual. | |
32 | ||
33 | ;;; Code: | |
34 | ||
35 | (define-module (srfi srfi-45) | |
36 | #:export (delay | |
37 | lazy | |
38 | force | |
d291d799 MW |
39 | eager |
40 | promise?) | |
41 | #:replace (delay force promise?) | |
3ed8d953 CJY |
42 | #:use-module (srfi srfi-9) |
43 | #:use-module (srfi srfi-9 gnu)) | |
f16a2007 | 44 | |
edb6de0b MW |
45 | (cond-expand-provide (current-module) '(srfi-45)) |
46 | ||
f16a2007 AR |
47 | (define-record-type promise (make-promise val) promise? |
48 | (val promise-val promise-val-set!)) | |
49 | ||
50 | (define-record-type value (make-value tag proc) value? | |
51 | (tag value-tag value-tag-set!) | |
52 | (proc value-proc value-proc-set!)) | |
53 | ||
0c65f52c AW |
54 | (define-syntax-rule (lazy exp) |
55 | (make-promise (make-value 'lazy (lambda () exp)))) | |
f16a2007 | 56 | |
65ad02b9 MW |
57 | (define (eager x) |
58 | (make-promise (make-value 'eager x))) | |
f16a2007 | 59 | |
0c65f52c | 60 | (define-syntax-rule (delay exp) |
65ad02b9 | 61 | (lazy (eager exp))) |
f16a2007 AR |
62 | |
63 | (define (force promise) | |
64 | (let ((content (promise-val promise))) | |
65 | (case (value-tag content) | |
65ad02b9 | 66 | ((eager) (value-proc content)) |
f16a2007 AR |
67 | ((lazy) (let* ((promise* ((value-proc content))) |
68 | (content (promise-val promise))) ; * | |
69 | (if (not (eqv? (value-tag content) 'eager)) ; * | |
70 | (begin (value-tag-set! content | |
71 | (value-tag (promise-val promise*))) | |
72 | (value-proc-set! content | |
73 | (value-proc (promise-val promise*))) | |
74 | (promise-val-set! promise* content))) | |
75 | (force promise)))))) | |
76 | ||
77 | ;; (*) These two lines re-fetch and check the original promise in case | |
78 | ;; the first line of the let* caused it to be forced. For an example | |
79 | ;; where this happens, see reentrancy test 3 below. | |
3ed8d953 CJY |
80 | |
81 | (define* (promise-visit promise #:key on-eager on-lazy) | |
82 | (define content (promise-val promise)) | |
83 | (case (value-tag content) | |
84 | ((eager) (on-eager (value-proc content))) | |
85 | ((lazy) (on-lazy (value-proc content))))) | |
86 | ||
87 | (set-record-type-printer! promise | |
88 | (lambda (promise port) | |
89 | (promise-visit promise | |
90 | #:on-eager (lambda (value) | |
91 | (format port "#<promise = ~s>" value)) | |
92 | #:on-lazy (lambda (proc) | |
93 | (format port "#<promise => ~s>" proc))))) |