module/ice-9/control.scm

   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
  28 (define (abort . args)
  29   (apply abort-to-prompt (default-prompt-tag) args))
  30
  31 (define-syntax %
  32   (syntax-rules ()
  33     ((_ expr)
  34      (call-with-prompt (default-prompt-tag)
  35                        (lambda () expr)
  36                        default-prompt-handler))
  37     ((_ expr handler)
  38      (call-with-prompt (default-prompt-tag)
  39                        (lambda () expr)
  40                        handler))
  41     ((_ tag expr handler)
  42      (call-with-prompt tag
  43                        (lambda () expr)
  44                        handler))))
  45
  46 ;; Each prompt tag has a type -- an expected set of arguments, and an unwritten
  47 ;; contract of what its handler will do on an abort. In the case of the default
  48 ;; prompt tag, we could choose to return values, exit nonlocally, or punt to the
  49 ;; user.
  50 ;;
  51 ;; We choose the latter, by requiring that the user return one value, a
  52 ;; procedure, to an abort to the prompt tag. That argument is then invoked with
  53 ;; the continuation as an argument, within a reinstated default prompt. In this
  54 ;; way the return value(s) from a default prompt are under the user's control.
  55 (define (default-prompt-handler k proc)
  56   (% (default-prompt-tag)
  57      (proc k)
  58      default-prompt-handler))
  59
  60 ;; Kindly provided by Wolfgang J Moeller <wjm@heenes.com>, modelled
  61 ;; after the ones by Oleg Kiselyov in
  62 ;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
  63 ;; public domain, as noted at the top of http://okmij.org/ftp/.
  64 ;;
  65 (define-syntax-rule (reset . body)
  66   (call-with-prompt (default-prompt-tag)
  67                     (lambda () . body)
  68                     (lambda (cont f) (f cont))))
  69
  70 (define-syntax-rule (shift var . body)
  71   (abort-to-prompt (default-prompt-tag)
  72                    (lambda (cont)
  73                      ((lambda (var) (reset . body))
  74                       (lambda vals (reset (apply cont vals)))))))
  75
  76 (define (reset* thunk)
  77   (reset (thunk)))
  78
  79 (define (shift* fc)
  80   (shift c (fc c)))
  81
  82 (define (call-with-escape-continuation proc)
  83   "Call PROC with an escape continuation."
  84   (let ((tag (list 'call/ec)))
  85     (call-with-prompt tag
  86                       (lambda ()
  87                         (proc (lambda args
  88                                 (apply abort-to-prompt tag args))))
  89                       (lambda (_ . args)
  90                         (apply values args)))))
  91
  92 (define call/ec call-with-escape-continuation)
  93
  94 (define-syntax-rule (let-escape-continuation k body ...)
  95   "Bind K to an escape continuation within the lexical extent of BODY."
  96   (let ((tag (list 'let/ec)))
  97     (call-with-prompt tag
  98                       (lambda ()
  99                         (let ((k (lambda args
 100                                    (apply abort-to-prompt tag args))))
 101                           body ...))
 102                       (lambda (_ . results)
 103                         (apply values results)))))
 104
 105 (define-syntax-rule (let/ec k body ...)
 106   (let-escape-continuation k body ...))