blob: c699bbdf8a7bdefe55e65487cf04bb00d5bbed59 (
plain) (
blame)
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
|
open Kahn
module Seq: S = struct
type 'a process = ('a -> unit) -> unit
type 'a channel = 'a Queue.t
type 'a in_port = 'a channel
type 'a out_port = 'a channel
type task = unit -> unit
let tasks = Queue.create ()
let push_cont (cont : 'a -> unit) (v : 'a) =
Queue.push (fun () -> cont v) tasks
let new_channel () =
let q = Queue.create () in
q, q
let output s = Format.printf "%s@?" s
let put x c =
fun cont ->
Queue.push x c;
push_cont cont ()
let rec get c =
fun cont ->
try
let v = Queue.pop c in push_cont cont v
with Queue.Empty ->
Queue.push (fun () -> get c cont) tasks
let rec try_get = function
| [] -> None
| (prt, f)::q ->
try
let v = Queue.pop prt in Some (f v)
with Queue.Empty -> try_get q
let rec select prt_list =
fun cont ->
match try_get prt_list with
| Some x -> push_cont cont x
| None -> Queue.push (fun () -> select prt_list cont) tasks
let select_default prt_list def =
fun cont ->
match try_get prt_list with
| Some x -> push_cont cont x
| None -> push_cont cont (def())
let doco l =
fun cont ->
let remain = ref (List.length l) in
List.iter (fun proc -> Queue.push (fun () -> proc (fun () -> remain := !remain - 1)) tasks) l;
let rec wait_x () =
if !remain = 0 then
cont ()
else
Queue.push wait_x tasks
in wait_x ()
let return v =
fun cont -> cont v
let bind (e : 'a process) (f : 'a -> 'b process) : 'b process =
fun cont ->
e (fun (r : 'a) -> f r cont)
let run e =
let ret = ref None in
e (fun v -> ret := Some v);
while not (Queue.is_empty tasks) do
let task = Queue.pop tasks in
task ()
done;
match !ret with
| Some k -> k
| None -> assert false
end
|
