/[svn]/types/patterns.ml
ViewVC logotype

Diff of /types/patterns.ml

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

revision 109 by abate, Tue Jul 10 17:06:47 2007 UTC revision 110 by abate, Tue Jul 10 17:07:14 2007 UTC
# Line 1  Line 1 
   let wrap s f x =  
     Printf.eprintf "%s start\n" s; flush stderr;  
     let r = f x in  
     Printf.eprintf "%s stop\n" s; flush stderr;  
     r  
   
1  type capture = string  type capture = string
2  type fv = capture SortedList.t  type fv = capture SortedList.t
3    
# Line 17  Line 11 
11    | Cup of descr * descr    | Cup of descr * descr
12    | Cap of descr * descr * bool    | Cap of descr * descr * bool
13    | Times of node * node    | Times of node * node
14      | Xml of node * node
15    | Record of Types.label * node    | Record of Types.label * node
16    | Capture of capture    | Capture of capture
17    | Constant of capture * Types.const    | Constant of capture * Types.const
# Line 64  Line 59 
59    (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))    (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
60  let times x y =  let times x y =
61    (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))    (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
62    let xml x y =
63      (Types.xml x.accept y.accept, SortedList.cup x.fv y.fv, Xml (x,y))
64  let record l x =  let record l x =
65    (Types.record l false x.accept, x.fv, Record (l,x))    (Types.record l false x.accept, x.fv, Record (l,x))
66  let capture x = (Types.any, [x], Capture x)  let capture x = (Types.any, [x], Capture x)
# Line 101  Line 98 
98            SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)            SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
99        | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->        | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->
100            SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)            SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)
101        | Times (p1,p2) ->        | Times (p1,p2) -> filter_prod fv p1 p2 t
102          | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
103          | Record (l,p) ->
104              filter_node (Types.Record.project t l) p
105          | Capture c ->
106              [(c, Types.Positive.ty t)]
107          | Constant (c, cst) ->
108              [(c, Types.Positive.ty (Types.constant cst))]
109    
110    and filter_prod ?kind fv p1 p2 t =
111            List.fold_left            List.fold_left
112              (fun accu (d1,d2) ->              (fun accu (d1,d2) ->
113                 let term =                 let term =
114                   SortedMap.union times_res           SortedMap.union times_res (filter_node d1 p1) (filter_node d2 p2)
                    (filter_node d1 p1)  
                    (filter_node d2 p2)  
115                 in                 in
116                 SortedMap.union cup_res accu term                 SortedMap.union cup_res accu term
117              )              )
118              (empty_res fv)              (empty_res fv)
119              (Types.Product.normal t)      (Types.Product.normal ?kind t)
120        | Record (l,p) ->  
           filter_node (Types.Record.project t l) p  
       | Capture c ->  
           [(c, Types.Positive.ty t)]  
       | Constant (c, cst) ->  
           [(c, Types.Positive.ty (Types.constant cst))]  
121    
122  and filter_node t p : (capture, Types.Positive.v) SortedMap.t =  and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
123    try MemoFilter.find (t,p) !memo_filter    try MemoFilter.find (t,p) !memo_filter
# Line 158  Line 157 
157      a     : Types.descr;      a     : Types.descr;
158      basic : unit line;      basic : unit line;
159      prod  : (node sl * node sl) line;      prod  : (node sl * node sl) line;
160      record: ((Types.label, node sl) sm) line      xml   : (node sl * node sl) line;
161        record: ((Types.label, node sl) sm) line;
162    
163    }    }
164    
165    type 'a nline = (result *  'a) list    type 'a nline = (result *  'a) list
# Line 173  Line 174 
174      na     : Types.descr;      na     : Types.descr;
175      nbasic : Types.descr nline;      nbasic : Types.descr nline;
176      nprod  : (nf * nf) nline;      nprod  : (nf * nf) nline;
177        nxml   : (nf * nf) nline;
178      nrecord: record nline      nrecord: record nline
179    }    }
180    
181    let empty = { v = []; catchv = [];    let empty = { v = []; catchv = [];
182                  a = Types.empty;                  a = Types.empty;
183                  basic = []; prod = []; record = [] }                  basic = []; prod = []; xml = []; record = [] }
184    let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)    let any_basic = Types.neg (List.fold_left Types.cup Types.empty
185                                   [Types.Product.any_xml;
186                                    Types.Product.any;
187                                    Types.Record.any])
188    let restrict t nf =    let restrict t nf =
189      let rec filter = function      let rec filter = function
190        | (key,acc) :: rem ->        | (key,acc) :: rem ->
# Line 194  Line 197 
197         a = Types.cap t nf.a;         a = Types.cap t nf.a;
198         basic = filter nf.basic;         basic = filter nf.basic;
199         prod = filter nf.prod;         prod = filter nf.prod;
200           xml = filter nf.xml;
201         record = filter nf.record;         record = filter nf.record;
202      }      }
203    
# Line 222  Line 226 
226        a = Types.cap nf1.a nf2.a;        a = Types.cap nf1.a nf2.a;
227        basic = merge merge_basic nf1.basic nf2.basic;        basic = merge merge_basic nf1.basic nf2.basic;
228        prod = merge merge_prod nf1.prod nf2.prod;        prod = merge merge_prod nf1.prod nf2.prod;
229          xml = merge merge_prod nf1.xml nf2.xml;
230        record = merge merge_record nf1.record nf2.record;        record = merge merge_record nf1.record nf2.record;
231      }      }
232    
# Line 234  Line 239 
239        a = Types.cup nf1.a nf2.a;        a = Types.cup nf1.a nf2.a;
240        basic = SortedMap.union Types.cup nf1.basic nf2.basic;        basic = SortedMap.union Types.cup nf1.basic nf2.basic;
241        prod  = SortedMap.union Types.cup nf1.prod nf2.prod;        prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
242          xml   = SortedMap.union Types.cup nf1.xml nf2.xml;
243        record = SortedMap.union Types.cup nf1.record nf2.record;        record = SortedMap.union Types.cup nf1.record nf2.record;
244      }      }
245    
# Line 246  Line 252 
252          a = acc;          a = acc;
253          prod = [ (src, ([p], [q])), acc ] }          prod = [ (src, ([p], [q])), acc ] }
254    
255      let xml acc p q =
256        let src_p = List.map (fun v -> (v,`Left)) p.fv
257        and src_q = List.map (fun v -> (v,`Right)) q.fv in
258        let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in
259        { empty with
260            v = SortedList.cup p.fv q.fv;
261            a = acc;
262            xml = [ (src, ([p], [q])), acc ] }
263    
264    let record acc l p =    let record acc l p =
265      let src = List.map (fun v -> (v, `Field l)) p.fv in      let src = List.map (fun v -> (v, `Field l)) p.fv in
266      { empty with      { empty with
# Line 259  Line 274 
274        a = Types.any;        a = Types.any;
275        basic = [ ([],()), any_basic ];        basic = [ ([],()), any_basic ];
276        prod  = [ ([],([],[])), Types.Product.any ];        prod  = [ ([],([],[])), Types.Product.any ];
277          xml   = [ ([],([],[])), Types.Product.any_xml ];
278        record = [ ([],[]), Types.Record.any ];        record = [ ([],[]), Types.Record.any ];
279      }      }
280    
# Line 269  Line 285 
285        a = Types.any;        a = Types.any;
286        basic = [ (l,()), any_basic ];        basic = [ (l,()), any_basic ];
287        prod  = [ (l,([],[])), Types.Product.any  ];        prod  = [ (l,([],[])), Types.Product.any  ];
288          xml  = [ (l,([],[])), Types.Product.any_xml  ];
289        record = [ (l,[]), Types.Record.any ];        record = [ (l,[]), Types.Record.any ];
290      }      }
291    
# Line 279  Line 296 
296        a = Types.any;        a = Types.any;
297        basic = [ (l,()), any_basic ];        basic = [ (l,()), any_basic ];
298        prod  = [ (l,([],[])), Types.Product.any  ];        prod  = [ (l,([],[])), Types.Product.any  ];
299          xml   = [ (l,([],[])), Types.Product.any_xml  ];
300        record = [ (l,[]), Types.Record.any ];        record = [ (l,[]), Types.Record.any ];
301      }      }
302    
# Line 288  Line 306 
306        a = t;        a = t;
307        basic = [ ([],()), Types.cap t any_basic ];        basic = [ ([],()), Types.cap t any_basic ];
308        prod  = [ ([],([],[])), Types.cap t Types.Product.any ];        prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
309          xml   = [ ([],([],[])), Types.cap t Types.Product.any_xml ];
310        record = [ ([],[]), Types.cap t Types.Record.any ];        record = [ ([],[]), Types.cap t Types.Record.any ];
311      }      }
312    
# Line 300  Line 319 
319        | Cap (p,q,_) -> cap (nf p) (nf q)        | Cap (p,q,_) -> cap (nf p) (nf q)
320        | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)        | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
321        | Times (p,q) -> times acc p q        | Times (p,q) -> times acc p q
322          | Xml (p,q) -> xml acc p q
323        | Capture x -> capture x        | Capture x -> capture x
324        | Constant (x,c) -> constant x c        | Constant (x,c) -> constant x c
325        | Record (l,p) -> record acc l p        | Record (l,p) -> record acc l p
# Line 310  Line 330 
330      let basic =      let basic =
331        List.map (fun ((res,()),acc) -> (res,acc))        List.map (fun ((res,()),acc) -> (res,acc))
332    
333      and prod =      and prod ?kind l =
334        let line accu (((res,(pl,ql)),acc)) =        let line accu (((res,(pl,ql)),acc)) =
335          let p = bigcap pl and q = bigcap ql in          let p = bigcap pl and q = bigcap ql in
336          let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in          let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
337          let t = Types.Product.normal acc in          let t = Types.Product.normal ?kind acc in
338          List.fold_left aux accu t in          List.fold_left aux accu t in
339        List.fold_left line []        List.fold_left line [] l
340    
341    
342      and record =      and record =
# Line 359  Line 379 
379        na      = nf.a;        na      = nf.a;
380        nbasic  = nlines (basic nf.basic);        nbasic  = nlines (basic nf.basic);
381        nprod   = nlines (prod nf.prod);        nprod   = nlines (prod nf.prod);
382          nxml    = nlines (prod ~kind:`XML nf.xml);
383        nrecord = nlines (record nf.record);        nrecord = nlines (record nf.record);
384      }      }
385    
# Line 373  Line 394 
394    and actions_kind = {    and actions_kind = {
395      basic: (Types.descr * result) list;      basic: (Types.descr * result) list;
396      prod: result dispatch dispatch;      prod: result dispatch dispatch;
397        xml: result dispatch dispatch;
398      record: record option;      record: record option;
399    }    }
400    and record =    and record =
# Line 425  Line 447 
447      in      in
448      aux f a 0      aux f a 0
449    
450    let combine_kind basic prod record =    let combine_kind basic prod xml record =
451      try (      try (
452        let rs = [] in        let rs = [] in
453        let rs = match basic with        let rs = match basic with
# Line 436  Line 458 
458          | `None -> rs          | `None -> rs
459          | `Ignore (`Ignore r) -> r :: rs          | `Ignore (`Ignore r) -> r :: rs
460          | _ -> raise Exit in          | _ -> raise Exit in
461          let rs = match xml with
462            | `None -> rs
463            | `Ignore (`Ignore r) -> r :: rs
464            | _ -> raise Exit in
465        let rs = match record with        let rs = match record with
466          | None -> rs          | None -> rs
467          | Some (`Result r) -> r :: rs          | Some (`Result r) -> r :: rs
# Line 448  Line 474 
474              -> `Ignore r              -> `Ignore r
475          | _ -> raise Exit          | _ -> raise Exit
476      )      )
477      with Exit -> `Kind { basic = basic; prod = prod; record = record }      with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }
478    
479    let combine (disp,act) =    let combine (disp,act) =
480      if Array.length act = 0 then `None      if Array.length act = 0 then `None
# Line 550  Line 576 
576          | `None -> ()          | `None -> ()
577          | `Switch (pos, yes, no) ->          | `Switch (pos, yes, no) ->
578              aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no              aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no
579          | `Result (code,t,arity) -> codes.(code) <- (t,arity, accu)          | `Result (code,t,arity) ->
580                codes.(code) <- (t,arity, accu)
581        in        in
582        aux 0 [] iface;        aux 0 [] iface;
583        let res = { id = !cur_id;        let res = { id = !cur_id;
# Line 576  Line 603 
603    let find_code d a =    let find_code d a =
604      let rec aux i = function      let rec aux i = function
605        | `Result (code,_,_) -> code        | `Result (code,_,_) -> code
606        | `None -> assert false        | `None ->
607              assert false
608        | `Switch (_,yes,no) ->        | `Switch (_,yes,no) ->
609            match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no            match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no
610      in      in
# Line 698  Line 726 
726        (fun x -> x)        (fun x -> x)
727    
728    
729    let rec dispatch_prod disp =    let rec dispatch_prod ?(kind=`Normal) disp =
730      let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in      let pl =
731      let t = Types.Product.get disp.t in        match kind with
732            | `Normal ->  Array.map (fun p -> p.Normal.nprod) disp.pl
733            | `XML -> Array.map (fun p -> p.Normal.nxml) disp.pl
734        in
735        let t = Types.Product.get ~kind disp.t in
736      get_tests pl      get_tests pl
737        (fun (res,(p,q)) -> [p, (res,q)], [])        (fun (res,(p,q)) -> [p, (res,q)], [])
738        (Types.Product.pi1 t)        (Types.Product.pi1 t)
# Line 852  Line 884 
884            let a = combine_kind            let a = combine_kind
885                      (dispatch_basic disp)                      (dispatch_basic disp)
886                      (dispatch_prod disp)                      (dispatch_prod disp)
887                        (dispatch_prod ~kind:`XML disp)
888                      (dispatch_record disp)                      (dispatch_record disp)
889            in            in
890            disp.actions <- Some a;            disp.actions <- Some a;
# Line 925  Line 958 
958              )              )
959              branches              branches
960      in      in
961      let print_prod  = function      let print_prod prefix = function
962        | `None -> ()        | `None -> ()
963        | `Ignore d2 ->        | `Ignore d2 ->
964            Format.fprintf ppf " | (v1,v2) -> @\n";            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
965            print_prod2 d2            print_prod2 d2
966        | `TailCall d ->        | `TailCall d ->
967            queue d;            queue d;
968            Format.fprintf ppf " | (v1,v2) -> @\n";            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
969            Format.fprintf ppf "      disp_%i v1@\n" d.id            Format.fprintf ppf "      disp_%i v1@\n" d.id
970        | `Dispatch (d,branches) ->        | `Dispatch (d,branches) ->
971            queue d;            queue d;
972            Format.fprintf ppf " | (v1,v2) -> @\n";            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
973            Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;            Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;
974            Array.iteri            Array.iteri
975              (fun code d2 ->              (fun code d2 ->
# Line 984  Line 1017 
1017      in      in
1018    
1019      List.iter print_basic actions.basic;      List.iter print_basic actions.basic;
1020      print_prod actions.prod;      print_prod "" actions.prod;
1021        print_prod "XML" actions.xml;
1022      print_record_opt ppf actions.record      print_record_opt ppf actions.record
1023    
1024    let print_actions ppf = function    let print_actions ppf = function
Legend:
Removed from v.109  
changed lines
  Added in v.110
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5