1; -*- coding:utf-8 -*-
2;;;
3;;; srfi-155
4;;;
5
6(define-module srfi-155
7  (use scheme.lazy :rename ((delay scheme-delay)
8                            (delay-force scheme-delay-force)))
9  (use srfi-154)
10  (export delay delay-force force
11	  make-promise promise?
12	  forcing-extent dynamic-extent?))
13(select-module srfi-155)
14
15;; Reference implementation:
16
17;; Copyright (C) Marc Nieper-Wißkirchen (2017).  All Rights Reserved.
18
19;; Permission is hereby granted, free of charge, to any person
20;; obtaining a copy of this software and associated documentation
21;; files (the "Software"), to deal in the Software without
22;; restriction, including without limitation the rights to use, copy,
23;; modify, merge, publish, distribute, sublicense, and/or sell copies
24;; of the Software, and to permit persons to whom the Software is
25;; furnished to do so, subject to the following conditions:
26
27;; The above copyright notice and this permission notice shall be
28;; included in all copies or substantial portions of the Software.
29
30;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
31;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
32;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
33;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
34;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
35;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
36;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
37;; SOFTWARE.
38
39(define current-forcing-extent (make-parameter #f))
40
41(define (forcing-extent)
42  (unless (current-forcing-extent)
43    (error "forcing-extent: there is no promise being forced"))
44  (current-forcing-extent))
45
46(define-syntax delay
47  (syntax-rules (force)
48    ((delay (force expression))
49     (delay-force expression))
50    ((delay expression)
51     (let ((dynamic-extent (current-dynamic-extent)))
52       (scheme-delay
53	(let ((forcing-extent (current-dynamic-extent)))
54	  (with-dynamic-extent dynamic-extent (lambda ()
55						(parameterize
56						    ((current-forcing-extent forcing-extent))
57						  expression)))))))))
58
59(define-syntax delay-force
60  (syntax-rules ()
61    ((delay-force expression)
62     (let ((dynamic-extent (current-dynamic-extent)))
63       (scheme-delay-force
64	(with-dynamic-extent dynamic-extent (lambda ()
65					      expression)))))))
66
67
68