1;; -*- coding:utf-8 -*- 2;;; 3;;; srfi-154 4;;; 5 6;; Based on the reference implementation, modified to fit Gauche style. 7;; NB: This is too slow for actual use because of the heavy use of call/cc. 8;; We'd probably expose internal dynamic extent chain. 9 10;; Copyright notice of the reference implementation: 11;; 12;; Copyright (C) Marc Nieper-Wißkirchen (2017). All Rights Reserved. 13;; 14;; Permission is hereby granted, free of charge, to any person 15;; obtaining a copy of this software and associated documentation 16;; files (the "Software"), to deal in the Software without 17;; restriction, including without limitation the rights to use, copy, 18;; modify, merge, publish, distribute, sublicense, and/or sell copies 19;; of the Software, and to permit persons to whom the Software is 20;; furnished to do so, subject to the following conditions: 21 22;; The above copyright notice and this permission notice shall be 23;; included in all copies or substantial portions of the Software. 24 25;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 26;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 27;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 28;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 29;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 30;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 31;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 32;; SOFTWARE. 33 34(define-module srfi-154 35 (export dynamic-extent? 36 current-dynamic-extent 37 with-dynamic-extent 38 dynamic-lambda)) 39(select-module srfi-154) 40 41(define-class <dynamic-extent> () 42 ((run :init-keyword :run))) 43 44(define (dynamic-extent? obj) (is-a? obj <dynamic-extent>)) 45 46(define (current-dynamic-extent) 47 (let/cc return 48 (receive (k thunk) (let/cc c 49 (return 50 (make <dynamic-extent> 51 :run (^[thunk] 52 (let/cc k (c k thunk)))))) 53 (call-with-values thunk k)))) 54 55(define (with-dynamic-extent dynamic-extent thunk) 56 ((slot-ref dynamic-extent 'run) thunk)) 57 58(define-syntax dynamic-lambda 59 (syntax-rules () 60 [(_ formals body) 61 (let1 dynamic-extent (current-dynamic-extent) 62 (^ formals 63 (with-dynamic-extent dynamic-extent (^[] body))))])) 64 65 66