/[svn]/runtime/run_dispatch.ml
ViewVC logotype

Diff of /runtime/run_dispatch.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 228 by abate, Tue Jul 10 17:12:31 2007 UTC revision 229 by abate, Tue Jul 10 17:17:01 2007 UTC
# Line 1  Line 1 
1  (* Running dispatchers *)  (* Running dispatchers *)
2    
 (* TODO: remove `Absent and clean .... *)  
   
3  open Value  open Value
4  open Patterns.Compile  open Patterns.Compile
5    
# Line 15  Line 13 
13         | Recompose (i,j) ->         | Recompose (i,j) ->
14             Pair ((if (i < 0) then v1 else r1.(i)),             Pair ((if (i < 0) then v1 else r1.(i)),
15                   (if (j < 0) then v2 else r2.(j)))                   (if (j < 0) then v2 else r2.(j)))
        | _ -> assert false  
     ) r in  
   (code,ret)  
   
 let make_result_record fields v bindings (code,r) =  
   let ret = Array.map  
     (function  
        | Catch -> v  
        | Const c -> const c  
        | Field (l,i) ->  
            if (i < 0) then List.assoc l fields  
            else (List.assoc l bindings).(i)  
        | _ -> assert false  
16      ) r in      ) r in
17    (code,ret)    (code,ret)
18    
# Line 43  Line 28 
28  let dummy_r = [||]  let dummy_r = [||]
29    
30  let rec run_dispatcher d v =  let rec run_dispatcher d v =
31    (*
32      Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
33      Patterns.Compile.print_dispatcher Format.std_formatter d;
34    *)
35    match actions d with    match actions d with
36      | AIgnore r -> make_result_basic v r      | AIgnore r -> make_result_basic v r
37      | AKind k -> run_disp_kind k v      | AKind k -> run_disp_kind k v
# Line 51  Line 40 
40    match v with    match v with
41    | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod    | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
42    | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml    | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
43    | Record r -> run_disp_record r v [] r false actions.record    | Record r -> run_disp_record false v r actions.record
44    | Atom a ->    | Atom a ->
45        run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic        run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic
46    | Char c ->    | Char c ->
# Line 61  Line 50 
50    | Abstraction (iface,_) ->    | Abstraction (iface,_) ->
51        run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)        run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
52          actions.basic          actions.basic
53      | Absent ->
54          run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
55    | v ->    | v ->
56        run_disp_kind actions (normalize v)        run_disp_kind actions (normalize v)
57    
58    
59  and run_disp_basic v f x =  and run_disp_basic v f =  function
60    match x with  (*  | [(_,r)] -> make_result_basic v r *)
   | [(_,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    | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
62    | _ -> assert false    | _ ->
63          assert false
64    
65    
66  and run_disp_prod v v1 v2 x =  and run_disp_prod v v1 v2 = function
   match x with  
67    | Impossible -> assert false    | Impossible -> assert false
68    | TailCall d1 -> run_dispatcher d1 v1    | TailCall d1 -> run_dispatcher d1 v1
69    | Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2    | Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
# Line 81  Line 71 
71        let (code1,r1) = run_dispatcher d1 v1 in        let (code1,r1) = run_dispatcher d1 v1 in
72        run_disp_prod2 v1 r1 v v2 b1.(code1)        run_disp_prod2 v1 r1 v v2 b1.(code1)
73    
74  and run_disp_prod2 v1 r1 v v2 x =  and run_disp_prod2 v1 r1 v v2 = function
   match x with  
75    | Impossible -> assert false    | Impossible -> assert false
76    | Ignore r -> make_result_prod v1 r1 v2 dummy_r v r    | Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
77    | TailCall d2 -> run_dispatcher d2 v2    | TailCall d2 -> run_dispatcher d2 v2
# Line 90  Line 79 
79        let (code2,r2) = run_dispatcher d2 v2 in        let (code2,r2) = run_dispatcher d2 v2 in
80        make_result_prod v1 r1 v2 r2 v b2.(code2)        make_result_prod v1 r1 v2 r2 v b2.(code2)
81    
82  and run_disp_record f v bindings fields other = function  and run_disp_record other v fields = function
83    | None -> assert false    | None -> assert false
84    | Some record -> run_disp_record' f v bindings fields other record    | Some (`Label (l,d)) ->
   
 and run_disp_record' f v bindings fields other = function  
   | `Result r ->  
       make_result_record f v bindings r  
   | `Result_other (_,r1,r2) ->  
       let other = other || fields <> [] in  
       make_result_record f v bindings (if other then r1 else r2)  
   | `Label (l, present, absent) ->  
85        let rec aux other = function        let rec aux other = function
86          | (l1,_) :: rem when l1 < l -> aux true rem          | (l1,_) :: rem when l1 < l -> aux true rem
87          | (l1,vl) :: rem when l1 = l ->          | (l1,vl) :: rem when l1 = l ->
88              run_disp_field f v bindings rem other l vl present              run_disp_record1 other vl rem d
89          | _ -> run_disp_record f v bindings fields other absent          | rem ->
90                run_disp_record1 other Absent rem d
91        in        in
92        aux other fields        aux other fields
93      | Some (`Nolabel (some,none)) ->
94          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_field f v bindings fields other l vl = function  and run_disp_record1 other v1 rem = function
100    | Impossible -> assert false    | Impossible -> assert false
101    | Ignore r -> run_disp_record' f v bindings fields other r    | TailCall d1 -> run_dispatcher d1 v1
102    | TailCall d -> run_dispatcher d vl    | Ignore d2 ->  run_disp_record2 other v1 dummy_r rem d2
103    | Dispatch (dl,bl) ->    | Dispatch (d1,b1) ->
104        let (codel,rl) = run_dispatcher dl vl in        let (code1,r1) = run_dispatcher d1 v1 in
105        run_disp_record' f v ((l,rl)::bindings) fields other bl.(codel)        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      | 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    
Legend:
Removed from v.228  
changed lines
  Added in v.229
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5