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
|
(* TEST
*)
open Effect
open Effect.Deep
exception E
type _ t += Yield : unit t
| Fork : (unit -> string) -> unit t
| Ping : unit t
exception Pong
let say = print_string
let run main =
let run_q = Queue.create () in
let enqueue k = Queue.push k run_q in
let rec dequeue () =
if Queue.is_empty run_q then `Finished
else continue (Queue.pop run_q) ()
in
let rec spawn f =
match_with f ()
{ retc = (function
| "ok" -> say "."; dequeue ()
| s -> failwith ("Unexpected result: " ^ s));
exnc = (function
| E -> say "!"; dequeue ()
| e -> raise e);
effc = fun (type a) (e : a t) ->
match e with
| Yield -> Some (fun (k : (a, _) continuation) ->
say ","; enqueue k; dequeue ())
| Fork f -> Some (fun (k : (a, _) continuation) ->
say "+"; enqueue k; spawn f)
| Ping -> Some (fun (k : (a, _) continuation) ->
say "["; discontinue k Pong)
| _ -> None }
in
spawn main
let test () =
say "A";
perform (Fork (fun () ->
perform Yield; say "C"; perform Yield;
begin match_with (fun () -> perform Ping; failwith "no pong?") ()
{ retc = (fun x -> x);
exnc = (function
| Pong -> say "]"
| e -> raise e);
effc = fun (type a) (e : a t) ->
match e with
| Yield -> Some (fun (k : (a,_) continuation) -> failwith "what?")
| _ -> None }
end;
raise E));
perform (Fork (fun () -> say "B"; "ok"));
say "D";
perform Yield;
say "E";
"ok"
let () =
let `Finished = run test in
say "\n"
|
