; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2013, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; 
; Last update: Jul 21, 2013
;
;;; simplifying Marc Feeley's continuation interface with some additions,
;;; i.a. by  Matt Might

(module continuations
  (continuations catch capture graft throw continuation? continuation
                 goto continuation->procedure)

  (import scheme
          (rename (only chicken
                        continuation-capture
                        continuation-graft
                        continuation-return
                        continuation?)
                  (continuation-capture capture)
                  (continuation-graft graft)
                  (continuation-return throw)))

(define-syntax catch
  (syntax-rules ()
    ((_ cont xpr . xprs)
     (capture (lambda (cont) xpr . xprs)))))

(define (continuation->procedure cont)
  (lambda vals (apply throw cont vals)))

(define (continuation)
  (capture (lambda (cc) (throw cc cc))))

(define (goto cc) (throw cc cc))

(define (continuations . args)
  (let ((lst '(catch capture continuation? continuation->procedure graft throw)))
    (if (null? args)
      lst
      (case (car args)
        ((catch)
         '(macro ()
             ((_ cont xpr . xprs)
              #t
              (capture (lambda (cont) xpr . xprs)))))
        ((capture)
         '(procedure (result)
            ((_ proc)
             (procedure? proc)
             "alias for continuation-capture")))
        ((continuation?)
         '(procedure (result)
            ((_ xpr) #t (boolean? result))))
        ((continuation->procedure)
         '(procedure (result)
            ((_ cont)
             (continuation? cont)
             (procedure? result))))
        ((graft)
         '(procedure (return)
            ((_ cont thunk)
             (and (continuation? cont) (procedure? thunk))
             "alias for continuation-graft")))
        ((throw)
         '(procedure (result)
            ((_ cont . vals)
             (continuation? cont)
             "alias for continuation-return")))
        ((continuation)
         '(procedure (result)
            ((_)
             #t
             (continuation? result))))
        ((goto cont)
         '(procedure (result)
            (continuation? cont)
            (continuation? result)))
        (else lst)))))

) ; end continuations