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