viewcvs.cgi/runtime/run_dispatch.ml

(* Running dispatchers *)

open Value


let make_result_prod v1 r1 v2 r2 v (code,r) = 
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | `Left i -> if (i < 0) then v1 else r1.(i)
       | `Right j -> if (j < 0) then v2 else r2.(j)
       | `Recompose (i,j) -> 
           Pair ((if (i < 0) then v1 else r1.(i)),
                 (if (j < 0) then v2 else r2.(j)))
       | _ -> assert false
    ) r in
  (code,ret)

let make_result_record fields v bindings (code,r) =
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | `Field (l,i) -> 
           if (i < 0) then List.assoc l fields
           else (List.assoc l bindings).(i)
       | _ -> assert false
    ) r in
  (code,ret)

let make_result_basic v (code,r) = 
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | _ -> assert false
    ) r in
  (code,ret)

let dummy_r = [||]

let rec run_dispatcher d v = 
  let actions = Patterns.Compile.actions d in
  match actions with
    | `Ignore r -> make_result_basic v r
    | `Kind k -> run_disp_kind k v

and run_disp_kind actions v =
  match v with
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
  | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.xml
  | Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
  | Atom a -> 
      run_disp_basic v (fun t -> Types.Atom.has_atom t a) 
        actions.Patterns.Compile.basic
  | Char c ->
      run_disp_basic v (fun t -> Types.Char.has_char t c) 
        actions.Patterns.Compile.basic
  | Integer i ->
      run_disp_basic v (fun t -> Types.Int.has_int t i) 
        actions.Patterns.Compile.basic
  | Abstraction (iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
        actions.Patterns.Compile.basic
  | v ->
      run_disp_kind actions (normalize v) 


and run_disp_basic v f x = 
  match x with
  | [(_,r)] -> make_result_basic v r
  | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
  | _ -> assert false
  

and run_disp_prod v v1 v2 x =
  match x with
  | `None -> assert false
  | `TailCall d1 -> run_dispatcher d1 v1
  | `Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
  | `Dispatch (d1,b1) ->
      let (code1,r1) = run_dispatcher d1 v1 in
      run_disp_prod2 v1 r1 v v2 b1.(code1)

and run_disp_prod2 v1 r1 v v2 x =
  match x with
  | `None -> assert false
  | `Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
  | `TailCall d2 -> run_dispatcher d2 v2
  | `Dispatch (d2,b2) ->
      let (code2,r2) = run_dispatcher d2 v2 in
      make_result_prod v1 r1 v2 r2 v b2.(code2)
            
and run_disp_record f v bindings fields = function
  | None -> assert false
  | Some record -> run_disp_record' f v bindings None fields record

and run_disp_record' f v bindings abs fields = function
  | `Result r -> make_result_record f v bindings r
  | `Absent -> run_disp_record f v bindings fields abs
  | `Label (l, present, absent) ->
      let rec aux = function
        | (l1,_) :: rem when l1 < l -> aux rem
        | (l1,vl) :: rem when l1 = l -> 
            run_disp_field f v bindings abs rem l vl present
        | _ -> run_disp_record f v bindings fields absent
      in
      aux fields

and run_disp_field f v bindings abs fields l vl = function
  | `None -> assert false
  | `Ignore r -> run_disp_record' f v bindings abs fields r
  | `TailCall d -> run_dispatcher d vl
  | `Dispatch (dl,bl) ->
      let (codel,rl) = run_dispatcher dl vl in
      run_disp_record' f v ((l,rl)::bindings) abs fields bl.(codel)
1	(* Running dispatchers *)
2
3	open Value
4
5
6	let make_result_prod v1 r1 v2 r2 v (code,r) =
7	let ret = Array.map
8	(function
9	\| `Catch -> v
10	\| `Const c -> const c
11	\| `Left i -> if (i < 0) then v1 else r1.(i)
12	\| `Right j -> if (j < 0) then v2 else r2.(j)
13	\| `Recompose (i,j) ->
14	Pair ((if (i < 0) then v1 else r1.(i)),
15	(if (j < 0) then v2 else r2.(j)))
16	\| _ -> assert false
17	) r in
18	(code,ret)
19
20	let make_result_record fields v bindings (code,r) =
21	let ret = Array.map
22	(function
23	\| `Catch -> v
24	\| `Const c -> const c
25	\| `Field (l,i) ->
26	if (i < 0) then List.assoc l fields
27	else (List.assoc l bindings).(i)
28	\| _ -> assert false
29	) r in
30	(code,ret)
31
32	let make_result_basic v (code,r) =
33	let ret = Array.map
34	(function
35	\| `Catch -> v
36	\| `Const c -> const c
37	\| _ -> assert false
38	) r in
39	(code,ret)
40
41	let dummy_r = [\|\|]
42
43	let rec run_dispatcher d v =
44	let actions = Patterns.Compile.actions d in
45	match actions with
46	\| `Ignore r -> make_result_basic v r
47	\| `Kind k -> run_disp_kind k v
48
49	and run_disp_kind actions v =
50	match v with
51	\| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
52	\| Xml (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.xml
53	\| Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
54	\| Atom a ->
55	run_disp_basic v (fun t -> Types.Atom.has_atom t a)
56	actions.Patterns.Compile.basic
57	\| Char c ->
58	run_disp_basic v (fun t -> Types.Char.has_char t c)
59	actions.Patterns.Compile.basic
60	\| Integer i ->
61	run_disp_basic v (fun t -> Types.Int.has_int t i)
62	actions.Patterns.Compile.basic
63	\| Abstraction (iface,_) ->
64	run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
65	actions.Patterns.Compile.basic
66	\| v ->
67	run_disp_kind actions (normalize v)
68
69
70	and run_disp_basic v f x =
71	match x with
72	\| [(_,r)] -> make_result_basic v r
73	\| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
74	\| _ -> assert false
75
76
77	and run_disp_prod v v1 v2 x =
78	match x with
79	\| `None -> assert false
80	\| `TailCall d1 -> run_dispatcher d1 v1
81	\| `Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
82	\| `Dispatch (d1,b1) ->
83	let (code1,r1) = run_dispatcher d1 v1 in
84	run_disp_prod2 v1 r1 v v2 b1.(code1)
85
86	and run_disp_prod2 v1 r1 v v2 x =
87	match x with
88	\| `None -> assert false
89	\| `Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
90	\| `TailCall d2 -> run_dispatcher d2 v2
91	\| `Dispatch (d2,b2) ->
92	let (code2,r2) = run_dispatcher d2 v2 in
93	make_result_prod v1 r1 v2 r2 v b2.(code2)
94
95	and run_disp_record f v bindings fields = function
96	\| None -> assert false
97	\| Some record -> run_disp_record' f v bindings None fields record
98
99	and run_disp_record' f v bindings abs fields = function
100	\| `Result r -> make_result_record f v bindings r
101	\| `Absent -> run_disp_record f v bindings fields abs
102	\| `Label (l, present, absent) ->
103	let rec aux = function
104	\| (l1,_) :: rem when l1 < l -> aux rem
105	\| (l1,vl) :: rem when l1 = l ->
106	run_disp_field f v bindings abs rem l vl present
107	\| _ -> run_disp_record f v bindings fields absent
108	in
109	aux fields
110
111	and run_disp_field f v bindings abs fields l vl = function
112	\| `None -> assert false
113	\| `Ignore r -> run_disp_record' f v bindings abs fields r
114	\| `TailCall d -> run_dispatcher d vl
115	\| `Dispatch (dl,bl) ->
116	let (codel,rl) = run_dispatcher dl vl in
117	run_disp_record' f v ((l,rl)::bindings) abs fields bl.(codel)