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

open Value
4
open Ident
5
open Patterns.Compile
6
7
8
9

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

29
30
31
32
33
34
35
36
37
let make_result_char ch (code,r) = 
  let ret = Array.map
    (function
       | Catch -> Char ch
       | Const c -> const c
       | _ -> assert false
    ) r in
  (code,ret)

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
let tail_string i j s q =
  if i + 1 = j then q else String (i + 1,j,s,q)
let make_result_string i j s q r1 r2 (code,r) = 
  let ret = Array.map
    (function
       | Catch -> String (i,j,s,q)
       | Const c -> const c
       | Left n -> if (n < 0) then Char (Chars.mk_char s.[i]) else r1.(n)
       | Right m -> if (m < 0) then tail_string i j s q else r2.(m)
       | Recompose (n,m) -> 
	   Pair ((if (n < 0) then Char (Chars.mk_char s.[i]) else r1.(n)),
		 (if (m < 0) then tail_string i j s q else r2.(m)))
    ) r in
  (code,ret)


54
55
56
57
58
59
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

60
61
62
let dummy_r = [||]

let rec run_dispatcher d v = 
63
64
65
66
(*
  Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
  Patterns.Compile.print_dispatcher Format.std_formatter d;
*)
67
68
69
  match actions d with
    | AIgnore r -> make_result_basic v r
    | AKind k -> run_disp_kind k v
70

71
72
and run_disp_kind actions v =
  match v with
73
74
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
  | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
75
  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
76
  | String (i,j,s,q) -> run_disp_string i j s q actions
77
  | Atom a -> 
78
      run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic
79
  | Char c ->
80
      run_disp_basic v (fun t -> Types.Char.has_char t c) actions.basic
81
  | Integer i ->
82
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
83
84
  | Abstraction (iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
85
        actions.basic
86
87
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
88
89
90
91
92
  | v ->
      run_disp_kind actions (normalize v) 



93
and run_disp_prod v v1 v2 = function
94
95
96
97
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
  | Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
  | Dispatch (d1,b1) ->
98
99
100
      let (code1,r1) = run_dispatcher d1 v1 in
      run_disp_prod2 v1 r1 v v2 b1.(code1)

101
and run_disp_prod2 v1 r1 v v2 = function
102
103
104
105
  | Impossible -> assert false
  | Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
106
107
108
      let (code2,r2) = run_dispatcher d2 v2 in
      make_result_prod v1 r1 v2 r2 v b2.(code2)
	    
109
and run_disp_record other v fields = function
110
  | None -> assert false
111
  | Some (RecLabel (l,d)) ->
112
113
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
114
115
116
117
	| (l1,vl) :: rem when l1 = l ->
	    run_disp_record1 other vl rem d
	| rem -> 
	    run_disp_record1 other Absent rem d
118
      in
119
      aux other fields
120
  | Some (RecNolabel (some,none)) ->
121
122
123
124
125
126
127
128
129
130
131
132
      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)
133

134
and run_disp_record2 other v1 r1 rem = function
135
  | Impossible -> assert false
136
137
138
139
140
141
142
143
144
  | 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
145
    | AKind k -> run_disp_record other Absent rem k.record
146
  
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

and run_disp_string i j s q actions = 
  if i = j then run_disp_kind actions q 
  else match actions.prod with
    | Impossible -> assert false
    | TailCall d1 -> run_disp_string_char d1 (Chars.mk_char s.[i])
    | Ignore d2 -> run_disp_string2 dummy_r i j s q d2
    | Dispatch (d1,b1) ->
	let (code1,r1) = run_disp_string_char d1 (Chars.mk_char s.[i]) in
	run_disp_string2 r1 i j s q b1.(code1)
and run_disp_string_char d ch =
  match actions d with
    | AIgnore r -> make_result_char ch r
    | AKind k -> 
	let rec aux ch = function
	  | [(_,r)] -> make_result_char ch r
	  | (t,r)::rem -> 
	      if Types.Char.has_char t ch then 
		make_result_char ch r 
	      else aux ch rem
	  | _ -> assert false
	in
	aux ch k.basic
and run_disp_string2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
173
      make_result_string i j s q r1 dummy_r r
174
175
176
  | TailCall d2 -> run_disp_string_loop i j s q d2
  | Dispatch (d2,b2) ->
      let (code2,r2) = run_disp_string_loop i j s q d2 in
177
      make_result_string i j s q r1 r2 b2.(code2)
178
179
180
181
182
183
184
and run_disp_string_loop i j s q d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_string (succ i) j s q k
  

 (* TODO: finir d'implmenter les capture pour les string ... *)