69 lines
2.5 KiB
Scheme
69 lines
2.5 KiB
Scheme
|
;;; event.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.
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define stop-event-timer
|
||
|
|
(lambda ()
|
||
|
|
($set-timer (most-positive-fixnum))))
|
||
|
|
|
||
|
|
(define start-event-timer
|
||
|
|
(lambda ()
|
||
|
|
; set timer by way of $event, so recurrent calls to "set-timer" or
|
||
|
|
; "{dis,en}able-interrupts" can't prevent interrupts
|
||
|
|
($event)))
|
||
|
|
|
||
|
|
(set! set-timer
|
||
|
|
(lambda (ticks)
|
||
|
|
(unless (and (fixnum? ticks) (fx>= ticks 0))
|
||
|
|
($oops 'set-timer "~s is not a nonnegative fixnum" ticks))
|
||
|
|
(let ([ticks-left (stop-event-timer)])
|
||
|
|
(let ([t ($tc-field 'timer-ticks ($tc))])
|
||
|
|
(if (fx> ticks 0)
|
||
|
|
(begin
|
||
|
|
($tc-field 'something-pending ($tc) #t)
|
||
|
|
($tc-field 'timer-ticks ($tc) ticks))
|
||
|
|
($tc-field 'timer-ticks ($tc) #f))
|
||
|
|
(if (fx= ($tc-field 'disable-count ($tc)) 0)
|
||
|
|
(let ([old (if t (fx+ t ticks-left) 0)])
|
||
|
|
(start-event-timer)
|
||
|
|
old)
|
||
|
|
(or t 0))))))
|
||
|
|
|
||
|
|
(set! disable-interrupts
|
||
|
|
(lambda ()
|
||
|
|
(let ([ticks (stop-event-timer)])
|
||
|
|
(let ([disable-count ($tc-field 'disable-count ($tc))])
|
||
|
|
(when (and (fx= disable-count 0) ($tc-field 'timer-ticks ($tc)))
|
||
|
|
($tc-field 'timer-ticks ($tc) (fx+ ($tc-field 'timer-ticks ($tc)) ticks)))
|
||
|
|
(when (fx= disable-count (most-positive-fixnum))
|
||
|
|
($oops 'disable-interrupts
|
||
|
|
"too many consecutive calls to disable-interrupts"))
|
||
|
|
(let ([disable-count (fx+ disable-count 1)])
|
||
|
|
($tc-field 'disable-count ($tc) disable-count)
|
||
|
|
disable-count)))))
|
||
|
|
|
||
|
|
(set! enable-interrupts
|
||
|
|
(lambda ()
|
||
|
|
(let ([ticks (stop-event-timer)])
|
||
|
|
(let ([disable-count (fx- ($tc-field 'disable-count ($tc)) 1)])
|
||
|
|
(case disable-count
|
||
|
|
[(-1) ($set-timer ticks) 0]
|
||
|
|
[(0) ($tc-field 'disable-count ($tc) 0)
|
||
|
|
(start-event-timer)
|
||
|
|
0]
|
||
|
|
[else ($tc-field 'disable-count ($tc) disable-count)
|
||
|
|
disable-count])))))
|
||
|
|
)
|