;; -*- mode: Scheme; -*-
;;
;; This file is distributed with WebGate for CHICKEN.
;; Copyright (c) 2006-2010 by Felix L. Winkelmann. All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; 2. 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.
;;
;; 3. The name of the authors may not be used to endorse or promote
;; products derived from this software without specific prior
;; written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
(declare (disable-interrupts))
(define error-output ##sys#standard-error)
(define standard-output ##sys#standard-output)
(define standard-input ##sys#standard-input)
(define (exception-handler ex)
(thread-signal! (thread-specific ##sys#current-thread) ex)
(continuation-drop #f) )
(define (with-limited-continuation thunk)
(let* ((t (make-thread
(lambda ()
(##sys#call-with-cthulhu
(lambda ()
(##sys#call-with-values thunk continuation-drop) ) ) ) ) )
(state (##sys#slot t 5)) )
(##sys#setislot state 0 '())
(##sys#setslot state 1 standard-input)
(##sys#setslot state 2 standard-output)
(##sys#setslot state 3 error-output)
(##sys#setslot state 4 exception-handler)
(thread-specific-set! t ##sys#current-thread)
(thread-start! t)
(thread-suspend! ##sys#current-thread)
(##sys#setslot (##sys#slot t 5) 5 (##sys#slot state 5))
(##sys#apply-values (##sys#slot t 2)) ) )
(define (continuation-drop . results)
(##sys#setslot ##sys#current-thread 2 results)
(thread-resume! (thread-specific ##sys#current-thread))
(##sys#thread-kill! ##sys#current-thread 'dead)
(##sys#schedule) )
(define (continuation-suspend store)
(##sys#apply-values
(##sys#call-with-direct-continuation
(lambda (k)
(let ((o (open-output-string)))
(serialize k o)
(##sys#call-with-values
(lambda () (store (get-output-string o)))
continuation-drop) ) ) ) ) )
(define (continuation-resume k . results)
(##sys#direct-return (with-input-from-string k deserialize) results) )