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

open Value
4
open Ident
5
open Patterns.Compile
6

7
8
9
10
11
12
13
(*
module Array = struct
  include Array
  let get = unsafe_get
end
*)

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

36
37
38
39
40
41
42
43
44
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)

45
46
let tail_string i j s q =
  if i + 1 = j then q else String (i + 1,j,s,q)
47

48
49
50
51
52
53
54
55
56
57
58
59
60
61
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)


62
63
64
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
65
  | _ -> assert false
66

67
68
69
let dummy_r = [||]

let rec run_dispatcher d v = 
70
71
72
73
(*
  Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
  Patterns.Compile.print_dispatcher Format.std_formatter d;
*)
74
75
76
  match actions d with
    | AIgnore r -> make_result_basic v r
    | AKind k -> run_disp_kind k v
77

78
79
and run_disp_kind actions v =
  match v with
80
81
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
  | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
82
  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
83
  | String (i,j,s,q) -> run_disp_string i j s q actions
84
85
  | Atom a -> make_result_basic v (Atoms.get_map a actions.atoms) 
  | Char c -> make_result_basic v (Chars.get_map c actions.chars) 
86
  | Integer i ->
87
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
88
89
  | Abstraction (iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
90
        actions.basic
91
92
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
93
94
95
96
97
  | v ->
      run_disp_kind actions (normalize v) 



98
and run_disp_prod v v1 v2 = function
99
100
101
102
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
  | Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
  | Dispatch (d1,b1) ->
103
104
105
      let (code1,r1) = run_dispatcher d1 v1 in
      run_disp_prod2 v1 r1 v v2 b1.(code1)

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

139
and run_disp_record2 other v1 r1 rem = function
140
  | Impossible -> assert false
141
142
143
144
145
146
147
148
149
  | 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
150
    | AKind k -> run_disp_record other Absent rem k.record
151
  
152
153
154
155
156
157
158
159
160
161
162
163
164

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
165
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
166
167
168
and run_disp_string2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
169
      make_result_string i j s q r1 dummy_r r
170
171
172
  | 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
173
      make_result_string i j s q r1 r2 b2.(code2)
174
175
176
177
178
179
180
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 ... *)