1;; A generic timer mech
2
3(define (tmr-mk targ timeout sig)
4  (list targ timeout 0 #f sig))
5
6(define (tmr-targ tmr) (car tmr))
7(define (tmr-timeout tmr) (cadr tmr))
8(define (tmr-count tmr) (caddr tmr))
9(define (tmr-on? tmr) (cadddr tmr))
10(define (tmr-sig tmr) (list-ref tmr 4))
11
12(define (tmr-set-count! tmr val) (set-car! (cddr tmr) val))
13(define (tmr-set-start! tmr val) (set-car! (cdddr tmr) val))
14
15(define (tmr-expired? tmr) (>= (tmr-count tmr) (tmr-timeout tmr)))
16(define (tmr-stop! tmr)
17  (tmr-set-count! tmr 0)
18  (tmr-set-start! tmr #f))
19(define (tmr-inc! tmr) (tmr-set-count! tmr (+ 1 (tmr-count tmr))))
20
21(define (ktmr-start! ktmr)
22  (let ((tmr (kobj-gob-data ktmr)))
23    (tmr-set-count! tmr 0)
24    (tmr-set-start! tmr #t)))
25
26(define (ktmr-exec ktmr)
27  (let ((tmr (kobj-gob-data ktmr)))
28    (display "tmr-exec")(newline)
29    (if (tmr-on? tmr)
30        (begin
31          (display "tmr-on")(newline)
32          (tmr-inc! tmr)
33          (if (tmr-expired? tmr)
34              (let* ((tag (tmr-targ tmr))
35                     (targ (safe-eval tag)))
36                (display "timer-expired")(newline)
37                (display "timer-sig:")(display (tmr-sig tmr))(newline)
38                (tmr-stop! tmr)
39                (if (notnull? tag)
40                    (signal-kobj targ (tmr-sig tmr) targ ktmr))))))))
41
42(define timer-ifc
43  (ifc nil
44       (method 'exec ktmr-exec)
45       (method 'start ktmr-start!)
46       ))
47
48(mk-obj-type 't_timer "timer" '() layer-mechanism timer-ifc)
49
50(define (mk-timer target-tag timeout sig)
51  (bind (kern-mk-obj t_timer 1)
52        (tmr-mk target-tag timeout sig)))
53