"Fossies" - the Fresh Open Source Software Archive 
Member "guile-3.0.5/module/ice-9/control.scm" (16 Jul 2018, 4181 Bytes) of package /linux/misc/guile-3.0.5.tar.xz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style:
standard) with prefixed line numbers.
Alternatively you can here
view or
download the uninterpreted source code file.
1 ;;; Beyond call/cc
2
3 ;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
4
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
9 ;;;;
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19 ;;; Code:
20
21 (define-module (ice-9 control)
22 #:re-export (call-with-prompt abort-to-prompt
23 default-prompt-tag make-prompt-tag)
24 #:export (% abort shift reset shift* reset*
25 call-with-escape-continuation call/ec
26 let-escape-continuation let/ec
27 suspendable-continuation?))
28
29 (load-extension (string-append "libguile-" (effective-version))
30 "scm_init_ice_9_control")
31
32 (define (abort . args)
33 (apply abort-to-prompt (default-prompt-tag) args))
34
35 (define-syntax %
36 (syntax-rules ()
37 ((_ expr)
38 (call-with-prompt (default-prompt-tag)
39 (lambda () expr)
40 default-prompt-handler))
41 ((_ expr handler)
42 (call-with-prompt (default-prompt-tag)
43 (lambda () expr)
44 handler))
45 ((_ tag expr handler)
46 (call-with-prompt tag
47 (lambda () expr)
48 handler))))
49
50 ;; Each prompt tag has a type -- an expected set of arguments, and an unwritten
51 ;; contract of what its handler will do on an abort. In the case of the default
52 ;; prompt tag, we could choose to return values, exit nonlocally, or punt to the
53 ;; user.
54 ;;
55 ;; We choose the latter, by requiring that the user return one value, a
56 ;; procedure, to an abort to the prompt tag. That argument is then invoked with
57 ;; the continuation as an argument, within a reinstated default prompt. In this
58 ;; way the return value(s) from a default prompt are under the user's control.
59 (define (default-prompt-handler k proc)
60 (% (default-prompt-tag)
61 (proc k)
62 default-prompt-handler))
63
64 ;; Kindly provided by Wolfgang J Moeller <wjm@heenes.com>, modelled
65 ;; after the ones by Oleg Kiselyov in
66 ;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
67 ;; public domain, as noted at the top of http://okmij.org/ftp/.
68 ;;
69 (define-syntax-rule (reset . body)
70 (call-with-prompt (default-prompt-tag)
71 (lambda () . body)
72 (lambda (cont f) (f cont))))
73
74 (define-syntax-rule (shift var . body)
75 (abort-to-prompt (default-prompt-tag)
76 (lambda (cont)
77 ((lambda (var) (reset . body))
78 (lambda vals (reset (apply cont vals)))))))
79
80 (define (reset* thunk)
81 (reset (thunk)))
82
83 (define (shift* fc)
84 (shift c (fc c)))
85
86 (define (call-with-escape-continuation proc)
87 "Call PROC with an escape continuation."
88 (let ((tag (list 'call/ec)))
89 (call-with-prompt tag
90 (lambda ()
91 (proc (lambda args
92 (apply abort-to-prompt tag args))))
93 (lambda (_ . args)
94 (apply values args)))))
95
96 (define call/ec call-with-escape-continuation)
97
98 (define-syntax-rule (let-escape-continuation k body ...)
99 "Bind K to an escape continuation within the lexical extent of BODY."
100 (let ((tag (list 'let/ec)))
101 (call-with-prompt tag
102 (lambda ()
103 (let ((k (lambda args
104 (apply abort-to-prompt tag args))))
105 body ...))
106 (lambda (_ . results)
107 (apply values results)))))
108
109 (define-syntax-rule (let/ec k body ...)
110 (let-escape-continuation k body ...))