viewcvs.cgi/runtime/run_dispatch.ml

(* Running dispatchers *)

open Value
open Patterns.Compile

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)))
    ) 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 rec run_disp_basic v f =  function
  | [(_,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

let dummy_r = [||]

let rec run_dispatcher d v = 
(*
  Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
  Patterns.Compile.print_dispatcher Format.std_formatter d;
*)
  match actions d with
    | AIgnore r -> make_result_basic v r
    | AKind 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.prod
  | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
  | Record r -> run_disp_record false v r actions.record
  | Atom a -> 
      run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic
  | Char c ->
      run_disp_basic v (fun t -> Types.Char.has_char t c) actions.basic
  | Integer i ->
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
  | Abstraction (iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
        actions.basic
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
  | v ->
      run_disp_kind actions (normalize v) 


and run_disp_prod v v1 v2 = function
  | Impossible -> 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 = function
  | Impossible -> 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 other v fields = function
  | None -> assert false
  | Some (RecLabel (l,d)) ->
      let rec aux other = function
        | (l1,_) :: rem when l1 < l -> aux true rem
        | (l1,vl) :: rem when l1 = l ->
            run_disp_record1 other vl rem d
        | rem -> 
            run_disp_record1 other Absent rem d
      in
      aux other fields
  | Some (RecNolabel (some,none)) ->
      let r = if other then some else none in
      match r with
        | Some r -> make_result_basic v r
        | None -> assert false
      
and run_disp_record1 other v1 rem = function
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
  | Ignore d2 ->  run_disp_record2 other v1 dummy_r rem d2
  | Dispatch (d1,b1) ->
      let (code1,r1) = run_dispatcher d1 v1 in
      run_disp_record2 other v1 r1 rem b1.(code1)

and run_disp_record2 other v1 r1 rem = function
  | Impossible -> assert false
  | Ignore r -> make_result_prod v1 r1 Absent dummy_r Absent r
  | TailCall d2 -> run_disp_record_loop other rem d2
  | Dispatch (d2,b2) ->
      let (code2,r2) = run_disp_record_loop other rem d2 in
      make_result_prod v1 r1 Absent r2 Absent b2.(code2)

and run_disp_record_loop other rem d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_record other (Pair(Absent,Absent)) rem k.record
  
1	abate	70	(* Running dispatchers *)
2
3			open Value
4	abate	172	open Patterns.Compile
5	abate	70
6			let make_result_prod v1 r1 v2 r2 v (code,r) =
7			let ret = Array.map
8			(function
9	abate	172	\| 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	abate	70	Pair ((if (i < 0) then v1 else r1.(i)),
15			(if (j < 0) then v2 else r2.(j)))
16			) r in
17			(code,ret)
18
19			let make_result_basic v (code,r) =
20			let ret = Array.map
21			(function
22	abate	172	\| Catch -> v
23			\| Const c -> const c
24	abate	70	\| _ -> assert false
25			) r in
26			(code,ret)
27
28	abate	230	let rec run_disp_basic v f = function
29			\| [(_,r)] -> make_result_basic v r
30			\| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
31			\| _ ->
32			assert false
33
34	abate	70	let dummy_r = [\|\|]
35
36			let rec run_dispatcher d v =
37	abate	229	(*
38			Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
39			Patterns.Compile.print_dispatcher Format.std_formatter d;
40			*)
41	abate	172	match actions d with
42			\| AIgnore r -> make_result_basic v r
43			\| AKind k -> run_disp_kind k v
44	abate	70
45	abate	71	and run_disp_kind actions v =
46			match v with
47	abate	172	\| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
48			\| Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
49	abate	229	\| Record r -> run_disp_record false v r actions.record
50	abate	70	\| Atom a ->
51	abate	172	run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic
52	abate	70	\| Char c ->
53	abate	172	run_disp_basic v (fun t -> Types.Char.has_char t c) actions.basic
54	abate	70	\| Integer i ->
55	abate	172	run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
56	abate	70	\| Abstraction (iface,_) ->
57			run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
58	abate	172	actions.basic
59	abate	229	\| Absent ->
60			run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
61	abate	70	\| v ->
62			run_disp_kind actions (normalize v)
63
64
65
66	abate	229	and run_disp_prod v v1 v2 = function
67	abate	172	\| Impossible -> assert false
68			\| TailCall d1 -> run_dispatcher d1 v1
69			\| Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
70			\| Dispatch (d1,b1) ->
71	abate	70	let (code1,r1) = run_dispatcher d1 v1 in
72			run_disp_prod2 v1 r1 v v2 b1.(code1)
73
74	abate	229	and run_disp_prod2 v1 r1 v v2 = function
75	abate	172	\| Impossible -> assert false
76			\| Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
77			\| TailCall d2 -> run_dispatcher d2 v2
78			\| Dispatch (d2,b2) ->
79	abate	70	let (code2,r2) = run_dispatcher d2 v2 in
80			make_result_prod v1 r1 v2 r2 v b2.(code2)
81
82	abate	229	and run_disp_record other v fields = function
83	abate	70	\| None -> assert false
84	abate	230	\| Some (RecLabel (l,d)) ->
85	abate	165	let rec aux other = function
86			\| (l1,_) :: rem when l1 < l -> aux true rem
87	abate	229	\| (l1,vl) :: rem when l1 = l ->
88			run_disp_record1 other vl rem d
89			\| rem ->
90			run_disp_record1 other Absent rem d
91	abate	70	in
92	abate	165	aux other fields
93	abate	230	\| Some (RecNolabel (some,none)) ->
94	abate	229	let r = if other then some else none in
95			match r with
96			\| Some r -> make_result_basic v r
97			\| None -> assert false
98
99			and run_disp_record1 other v1 rem = function
100			\| Impossible -> assert false
101			\| TailCall d1 -> run_dispatcher d1 v1
102			\| Ignore d2 -> run_disp_record2 other v1 dummy_r rem d2
103			\| Dispatch (d1,b1) ->
104			let (code1,r1) = run_dispatcher d1 v1 in
105			run_disp_record2 other v1 r1 rem b1.(code1)
106	abate	70
107	abate	229	and run_disp_record2 other v1 r1 rem = function
108	abate	172	\| Impossible -> assert false
109	abate	229	\| Ignore r -> make_result_prod v1 r1 Absent dummy_r Absent r
110			\| TailCall d2 -> run_disp_record_loop other rem d2
111			\| Dispatch (d2,b2) ->
112			let (code2,r2) = run_disp_record_loop other rem d2 in
113			make_result_prod v1 r1 Absent r2 Absent b2.(code2)
114
115			and run_disp_record_loop other rem d =
116			match actions d with
117			\| AIgnore r -> make_result_basic Absent r
118			\| AKind k -> run_disp_record other (Pair(Absent,Absent)) rem k.record
119