"Fossies" - the Fresh Open Source Software Archive

Member "guile-3.0.8/module/ice-9/control.scm" (16 Jul 2018, 4181 Bytes) of package /linux/misc/guile-3.0.8.tar.xz:

    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 ...))