WebGate

Artifact 35356fb30cd63cceaa19b28e2e0ff5af6220b055:

• File suspension.scm — part of check-in [c29262e9f4] at 2013-05-30 17:00:20 on branch trunk — Protobuf and suspension based serialization of continuations, request parameter utilities, reader extension loader (user: murphy size: 3134)

;; -*- 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) )