run_dispatch.ml 3.61 KB
Newer Older
1
2
3
(* Running dispatchers *)

open Value
4
open Patterns.Compile
5
6
7
8

let make_result_prod v1 r1 v2 r2 v (code,r) = 
  let ret = Array.map
    (function
9
10
11
12
13
       | 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) -> 
14
15
16
17
18
19
20
21
	   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
22
23
       | Catch -> v
       | Const c -> const c
24
25
26
27
28
29
30
       | _ -> assert false
    ) r in
  (code,ret)

let dummy_r = [||]

let rec run_dispatcher d v = 
31
32
33
34
(*
  Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
  Patterns.Compile.print_dispatcher Format.std_formatter d;
*)
35
36
37
  match actions d with
    | AIgnore r -> make_result_basic v r
    | AKind k -> run_disp_kind k v
38

39
40
and run_disp_kind actions v =
  match v with
41
42
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
  | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
43
  | Record r -> run_disp_record false v r actions.record
44
  | Atom a -> 
45
      run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic
46
  | Char c ->
47
      run_disp_basic v (fun t -> Types.Char.has_char t c) actions.basic
48
  | Integer i ->
49
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
50
51
  | Abstraction (iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
52
        actions.basic
53
54
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
55
56
57
58
  | v ->
      run_disp_kind actions (normalize v) 


59
60
and run_disp_basic v f =  function
(*  | [(_,r)] -> make_result_basic v r *)
61
  | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
62
63
  | _ -> 
      assert false
64
65
  

66
and run_disp_prod v v1 v2 = function
67
68
69
70
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
  | Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
  | Dispatch (d1,b1) ->
71
72
73
      let (code1,r1) = run_dispatcher d1 v1 in
      run_disp_prod2 v1 r1 v v2 b1.(code1)

74
and run_disp_prod2 v1 r1 v v2 = function
75
76
77
78
  | Impossible -> assert false
  | Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
79
80
81
      let (code2,r2) = run_dispatcher d2 v2 in
      make_result_prod v1 r1 v2 r2 v b2.(code2)
	    
82
and run_disp_record other v fields = function
83
  | None -> assert false
84
  | Some (`Label (l,d)) ->
85
86
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
87
88
89
90
	| (l1,vl) :: rem when l1 = l ->
	    run_disp_record1 other vl rem d
	| rem -> 
	    run_disp_record1 other Absent rem d
91
      in
92
      aux other fields
93
94
95
96
97
98
99
100
101
102
103
104
105
  | Some (`Nolabel (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)
106

107
and run_disp_record2 other v1 r1 rem = function
108
  | Impossible -> assert false
109
110
111
112
113
114
115
116
117
118
119
  | 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