worlds/haxima-1.002/timer.scm

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