scheme-pearls/engine-simple.scm at main · evalwhen/scheme-pearls · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
;; simple engine implementation with home-made timer

;; --------------- home-made timer implementation ---------------

;; To use Chez Scheme's system timer, just comment out this section
;; and uncomment the other definition of 'lambda@t'

(define handler #f)
(define clock 0)

(define timer-interrupt-handler
  (lambda (f)
    (set! handler f)))

(define set-timer
  (lambda (ticks)
    (let ([time-left clock])
      (set! clock ticks)
      time-left)))

(define decrement-timer
  (lambda ()
    (cond
     [(= clock 0) (handler)]
     [else
      (set! clock (- clock 1))])))

(define-syntax lambda@t
  (syntax-rules ()
    [(_ args e0 e1 ...)
     (lambda args (decrement-timer) e0 e1 ...)]))

;; (define-syntax lambda@t
;;   (syntax-rules ()
;;     [(_ args e0 e1 ...)
;;      (lambda args e0 e1 ...)]))

(define-syntax atomic
  (syntax-rules ()
    [(_ e0 e ...)
     (let ([rest (set-timer 0)])
       (let ([value (begin e0 e ...)])
         (set-timer rest)
         value))]))

(define show
  (lambda args
    (atomic
     (for-each display args)
     (newline))))


;; --------------- engine ---------------

(define exit #f)

(define eng
  (lambda (k)
    (lambda (ticks complete expire)
      (cond
       [(= ticks 0)
        (expire (eng k))]
       [else
        (let ([kv (run-engine k ticks)])
          (cond
           [(procedure? kv)             ; continuation
            (expire (eng kv))]
           [else                        ; value
            (let ([rest (set-timer 0)])
              (complete rest kv))]))]))))

(define make-engine
  (lambda (thunk)
    (eng (lambda (ticks)
           (set-timer ticks)
           (exit (thunk))))))

(define run-engine
  (lambda (thunk ticks)
    (call/cc
     (lambda (k)
       (set! exit k)
       (set-timer 0)
       (timer-interrupt-handler block)
       (thunk ticks)))))

(define block
  (lambda ()
    (set-timer (call/cc (lambda (k) (exit k))))))

(define engine-return (lambda (args) (exit args)))
(define engine-block (lambda () (set-timer 0) (block)))


;; --------------- tests ---------------

(define fib
  (lambda@t (n)
    (cond
     [(= n 0) 0]
     [(= n 1) 1]
     [else
      (+ (fib (- n 1)) (fib (- n 2)))])))

(define e1
  (make-engine
   (lambda ()
     (fib 12))))


(e1 100
    (lambda (t v) (display (list t v)))
    (lambda (e)
      (set! e1 e)
      (display "expired")
      (newline)))

(e1 100
    (lambda (t v) (display (list t v)))
    (lambda (e)
      (set! e1 e)
      (display "expired")
      (newline)))

(e1 100
    (lambda (t v) (display (list t v)))
    (lambda (e)
      (set! e1 e)
      (display "expired")
      (newline)))

(e1 100
    (lambda (t v) (display (list t v)))
    (lambda (e)
      (set! e1 e)
      (display "expired")
      (newline)))

(e1 100
    (lambda (t v) (display (list t v)))
    (lambda (e)
      (set! e1 e)
      (display "expired")
      (newline)))