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