135 lines
4.2 KiB
Scheme
135 lines
4.2 KiB
Scheme
;;; engine.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; Notes:
|
|
;;; The engine code defines three functions: make-engine,
|
|
;;; engine-block, and engine-return.
|
|
|
|
;;; Keyboard interrupts are caught while an engine is running
|
|
;;; and the engine disabled while the handler is running.
|
|
|
|
;;; All of the engine code is defined within local state
|
|
;;; containing the following variables:
|
|
;;; *active* true iff an engine is running
|
|
;;; *exit* the continuation to the engine invoker
|
|
;;; *keybd* the saved keyboard interrupt handler
|
|
;;; *timer* the saved timer interrupt handler
|
|
|
|
|
|
(let ()
|
|
|
|
(define-threaded *exit*)
|
|
(define-threaded *keybd*)
|
|
(define-threaded *timer*)
|
|
(define-threaded *active* #f)
|
|
|
|
(define cleanup
|
|
(lambda (who)
|
|
(unless *active* ($oops who "no engine active"))
|
|
(set! *active* #f)
|
|
(keyboard-interrupt-handler *keybd*)
|
|
(timer-interrupt-handler *timer*)
|
|
(set! *keybd* (void))
|
|
(set! *exit* (void))
|
|
(set! *timer* (void))))
|
|
|
|
(define setup
|
|
(lambda (exit)
|
|
(set! *active* #t)
|
|
(set! *keybd* (keyboard-interrupt-handler))
|
|
(keyboard-interrupt-handler (exception *keybd*))
|
|
(set! *timer* (timer-interrupt-handler))
|
|
(timer-interrupt-handler block)
|
|
(set! *exit* exit)))
|
|
|
|
(define block
|
|
; disable engine and return the continuation
|
|
(lambda ()
|
|
(let ([exit *exit*])
|
|
(cleanup 'engine-block)
|
|
(set-timer (call/cc (lambda (k) (exit (lambda () k))))))))
|
|
|
|
(define return
|
|
; disable engine and return list (ticks value ...)
|
|
(lambda (args)
|
|
(let ([n (set-timer 0)])
|
|
(let ([exit *exit*])
|
|
(cleanup 'engine-return)
|
|
(exit (lambda () (cons n args)))))))
|
|
|
|
(define exception
|
|
; disable engine while calling the handler
|
|
(lambda (handler)
|
|
(lambda args
|
|
(let ([ticks (set-timer 0)])
|
|
(let ([exit *exit*])
|
|
(cleanup 'engine-exception)
|
|
(apply handler args)
|
|
(setup exit)
|
|
(if (= ticks 0) (block) (set-timer ticks)))))))
|
|
|
|
(define run-engine
|
|
; run a continuation as an engine
|
|
(lambda (k ticks)
|
|
((call/cc
|
|
(lambda (exit)
|
|
(set-timer 0)
|
|
(when *active* ($oops 'engine "cannot nest engines"))
|
|
(setup exit)
|
|
(k ticks))))))
|
|
|
|
(define eng
|
|
; create an engine from a procedure or continuation
|
|
(lambda (k)
|
|
(lambda (ticks complete expire)
|
|
(unless (and (fixnum? ticks) (not (negative? ticks)))
|
|
($oops 'engine "invalid ticks ~s" ticks))
|
|
(unless (procedure? complete)
|
|
($oops 'engine "~s is not a procedure" complete))
|
|
(unless (procedure? expire)
|
|
($oops 'engine "~s is not a procedure" expire))
|
|
(if (= ticks 0)
|
|
(expire (eng k))
|
|
(let ([x (run-engine k ticks)])
|
|
(if (procedure? x)
|
|
(expire (eng x))
|
|
(apply complete x)))))))
|
|
|
|
(set! engine-return (lambda args (return args)))
|
|
|
|
(set! engine-block (lambda () (set-timer 0) (block)))
|
|
|
|
(set! make-engine
|
|
(lambda (x)
|
|
(unless (procedure? x) ($oops 'make-engine "~s is not a procedure" x))
|
|
(eng (lambda (ticks)
|
|
(with-exception-handler
|
|
(lambda (c)
|
|
(let ([ticks (set-timer 0)])
|
|
(let ([exit *exit*])
|
|
(cleanup 'raise)
|
|
(call/cc
|
|
(lambda (k)
|
|
(exit
|
|
(lambda ()
|
|
(let-values ([vals (raise-continuable c)])
|
|
(setup exit)
|
|
(if (= ticks 0) (block) (set-timer ticks))
|
|
(apply k vals)))))))))
|
|
(lambda ()
|
|
(set-timer ticks)
|
|
(call-with-values x (lambda args (return args)))))))))
|
|
)
|