viewcvs.cgi/runtime/run_dispatch.ml

(* Running dispatchers *)

(* TODO: remove `Absent and clean .... *)

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 false 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 other = function
  | None -> assert false
  | Some record -> run_disp_record' f v bindings fields other record

and run_disp_record' f v bindings fields other = function
  | `Result r ->
      make_result_record f v bindings r
  | `Result_other (_,r1,r2) -> 
      let other = other || fields <> [] in
      make_result_record f v bindings (if other then r1 else r2)
  | `Label (l, present, absent) ->
      let rec aux other = function
        | (l1,_) :: rem when l1 < l -> aux true rem
        | (l1,vl) :: rem when l1 = l -> 
            run_disp_field f v bindings rem other l vl present
        | _ -> run_disp_record f v bindings fields other absent
      in
      aux other fields

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