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