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