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

Diff of /types/patterns.ml

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

revision 38 by abate, Tue Jul 10 16:58:37 2007 UTC revision 39 by abate, Tue Jul 10 17:00:05 2007 UTC
# Line 127  Line 127 
127        ]        ]
128    type result = (capture, source) sm    type result = (capture, source) sm
129    
130      type 'a line = (result * 'a, Types.descr) sm
131    type nf = {    type nf = {
132      v     : fv;      v     : fv;
133      a     : Types.descr;      a     : Types.descr;
134      basic : (result, Types.descr) sm;      basic : unit line;
135      prod  : (result * Types.descr * node sl * node sl) sl;      prod  : (node sl * node sl) line;
136      record: (result * Types.descr * (Types.label, node sl) sm) sl;      record: ((Types.label, node sl) sm) line
137      }
138    
139      type 'a nline = (result *  'a) list
140      type record =
141          [ `Success
142          | `Fail
143          | `Dispatch of (nf * record) list
144          | `Label of Types.label * (nf * record) list * record ]
145      type normal = {
146        nbasic : Types.descr nline;
147        nprod  : (nf * nf) nline;
148        nrecord: record nline
149    }    }
150    
151    let empty = { v = []; a = Types.empty; basic = []; prod = []; record = [] }    let empty = { v = []; a = Types.empty; basic = []; prod = []; record = [] }
# Line 140  Line 153 
153    
154    
155    let restrict t nf =    let restrict t nf =
156      let map_filter f l =      let rec filter = function
157        let g accu x = match f x with Some y -> y::accu | None -> accu in        | (key,acc) :: rem ->
158        SortedList.from_list (List.fold_left g [] l) in            let acc = Types.cap t acc in
159              if Types.is_empty acc then filter rem else (key,acc) :: (filter rem)
160      let aux_basic (res,bt) =        | [] -> []
161        let bt = Types.cap t bt in      in
       if Types.is_empty bt then None else Some (res,bt) in  
   
     let aux_prod (res,bt,p,q) =  
       let bt = Types.cap t bt in  
       if Types.is_empty bt then None else Some (res,bt,p,q) in  
   
     let aux_record (res,bt,r) =  
       let bt = Types.cap t bt in  
       if Types.is_empty bt then None else Some (res,bt,r) in  
   
162      {  v = nf.v;      {  v = nf.v;
163         a = Types.cap t nf.a;         a = Types.cap t nf.a;
164         basic = map_filter aux_basic nf.basic;         basic = filter nf.basic;
165         prod = map_filter aux_prod nf.prod;         prod = filter nf.prod;
166         record = map_filter aux_record nf.record;         record = filter nf.record;
167      }      }
168    
169    let fus = SortedMap.union_disj    let fus = SortedMap.union_disj
170    let slcup = SortedList.cup    let slcup = SortedList.cup
171    
172    let cap nf1 nf2 =    let cap nf1 nf2 =
173      let aux f x1 x2 =      let merge f lines1 lines2 =
174        SortedList.from_list        let m =
175          (List.fold_left (fun accu a -> List.fold_left (f a) accu x2) [] x1) in          List.fold_left
176              (fun accu ((res1,x1),acc1) ->
177      let aux_basic (res1,t1) accu (res2,t2) =               List.fold_left
178        let t = Types.cap t1 t2 in               (fun accu ((res2,x2),acc2) ->
179        if Types.is_empty t then accu                  let acc = Types.cap acc1 acc2 in
180        else (fus res1 res2, t)::accu in                  if Types.is_empty acc then accu
181                    else ((fus res1 res2, f x1 x2),acc) :: accu
182      let aux_prod (res1,t1,p1,q1) accu (res2,t2,p2,q2) =               ) accu lines2
183        let t = Types.cap t1 t2 in            ) [] lines1 in
184        if Types.is_empty t then accu        SortedMap.from_list Types.cup m
185        else (fus res1 res2, t, slcup p1 p2, slcup q1 q2)::accu in      in
186        let merge_basic () () = ()
187      let aux_record (res1,t1,r1) accu (res2,t2,r2) =      and merge_prod (p1,q1) (p2,q2) = slcup p1 p1, slcup q1 q2
188        let t = Types.cap t1 t2 in      and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
       if Types.is_empty t then accu  
       else (fus res1 res2, t, SortedMap.union slcup r1 r2)  
         ::accu in  
   
189      { v = SortedList.cup nf1.v nf2.v;      { v = SortedList.cup nf1.v nf2.v;
190        a = Types.cap nf1.a nf2.a;        a = Types.cap nf1.a nf2.a;
191        basic = SortedMap.from_sorted_list Types.cup        basic = merge merge_basic nf1.basic nf2.basic;
192                  (aux aux_basic nf1.basic nf2.basic);        prod = merge merge_prod nf1.prod nf2.prod;
193        prod = aux aux_prod nf1.prod nf2.prod;        record = merge merge_record nf1.record nf2.record;
       record = aux aux_record nf1.record nf2.record;  
194      }      }
195    
196    
197    
198    let cup acc1 nf1 nf2 =    let cup acc1 nf1 nf2 =
199      let nf2 = restrict (Types.neg acc1) nf2 in      let nf2 = restrict (Types.neg acc1) nf2 in
200      { v = SortedList.cup nf1.v nf2.v;      { v = nf1.v; (* = nf2.v *)
201        a = Types.cup nf1.a nf2.a;        a = Types.cup nf1.a nf2.a;
202        basic = SortedMap.union Types.cup nf1.basic nf2.basic;        basic = SortedMap.union Types.cup nf1.basic nf2.basic;
203        prod  = SortedList.cup nf1.prod nf2.prod;        prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
204        record = SortedList.cup nf1.record nf2.record;        record = SortedMap.union Types.cup nf1.record nf2.record;
205      }      }
206    
207    let times acc p q =    let times acc p q =
# Line 213  Line 211 
211      { empty with      { empty with
212          v = SortedList.cup p.fv q.fv;          v = SortedList.cup p.fv q.fv;
213          a = acc;          a = acc;
214          prod = [ src, acc, [p], [q] ] }          prod = [ (src, ([p], [q])), acc ] }
215    
216    let record acc l p =    let record acc l p =
217      let src = List.map (fun v -> (v, `Field l)) p.fv in      let src = List.map (fun v -> (v, `Field l)) p.fv in
218      { empty with      { empty with
219          v = p.fv;          v = p.fv;
220          a = acc;          a = acc;
221          record = [ src, acc, [l,[p]] ] }          record = [ (src, [l,[p]]), acc ] }
222    
223    let any =    let any =
224      { v = [];      { v = [];
225        a = Types.any;        a = Types.any;
226        basic = [ [], any_basic ];        basic = [ ([],()), any_basic ];
227        prod  = [ [], Types.Product.any,[],[] ];        prod  = [ ([],([],[])), Types.Product.any ];
228        record = [ [], Types.Record.any,[] ];        record = [ ([],[]), Types.Record.any ];
229      }      }
230    
231    let capture x =    let capture x =
232      let l = [x,`Catch] in      let l = [x,`Catch] in
233      { v = [x];      { v = [x];
234        a = Types.any;        a = Types.any;
235        basic = [ l, any_basic ];        basic = [ (l,()), any_basic ];
236        prod  = [ l, Types.Product.any,[],[] ];        prod  = [ (l,([],[])), Types.Product.any  ];
237        record = [ l, Types.Record.any,[] ];        record = [ (l,[]), Types.Record.any ];
238      }      }
239    
240    let constant x c =    let constant x c =
241      let l = [x,`Const c] in      let l = [x,`Const c] in
242      { v = [x];      { v = [x];
243        a = Types.any;        a = Types.any;
244        basic = [ l, any_basic ];        basic = [ (l,()), any_basic ];
245        prod  = [ l, Types.Product.any,[],[] ];        prod  = [ (l,([],[])), Types.Product.any  ];
246        record = [ l, Types.Record.any,[] ];        record = [ (l,[]), Types.Record.any ];
247      }      }
248    
249    let constr t =    let constr t =
250      { v = [];      { v = [];
251        a = t;        a = t;
252        basic = [ [], Types.cap t any_basic ];        basic = [ ([],()), Types.cap t any_basic ];
253        prod  = [ [], Types.cap t Types.Product.any,[],[] ];        prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
254        record = [ [], Types.cap t Types.Record.any,[] ];        record = [ ([],[]), Types.cap t Types.Record.any ];
255      }      }
256    
257  (* Put a pattern in normal form *)  (* Put a pattern in normal form *)
# Line 280  Line 278 
278        masks : (mask * int) list;        masks : (mask * int) list;
279        basic : (Types.descr * (result option list)) list;        basic : (Types.descr * (result option list)) list;
280        prod  : prod;        prod  : prod;
281        record: record;        record: record option;
282      }      }
283      and prod = disp * (mask * disp * (mask * prod_result) list) list      and prod = disp * (mask * disp * (mask * prod_result) list) list
284      and prod_result = (result * (int * int)) option list      and prod_result = (result * (int * int)) option list
# Line 294  Line 292 
292      and disp = Types.descr * nf SortedList.t      and disp = Types.descr * nf SortedList.t
293    end    end
294    
295      let normal nf =
296        let basic =
297          List.map (fun ((res,()),acc) -> (res,acc))
298    
299        and prod =
300          let line accu (((res,(pl,ql)),acc)) =
301            let p = bigcap pl and q = bigcap ql in
302            let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
303            List.fold_left aux accu (Types.Product.normal acc) in
304          List.fold_left line []
305    
306        and record =
307          let rec aux nr fields =
308            match (nr,fields) with
309              | (`Success, []) -> `Success
310              | (`Fail,_) -> `Fail
311              | (`Success, (l2,pl)::fields) ->
312                  `Label (l2, [bigcap pl, aux nr fields], `Fail)
313              | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
314                  `Label (l2, [bigcap pl, aux nr fields], `Fail)
315              | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
316                  let p = bigcap pl in
317                  let pr =
318                    List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
319                  `Label (l1, pr, `Fail)
320              | (`Label (l1, pr, ab),_) ->
321                  let pr =
322                    List.map (fun (t,x) -> (constr t, aux x fields)) pr in
323                  `Label (l1, pr, aux ab fields)
324          in
325    
326          let line accu ((res,fields),acc) =
327            let nr = Types.Record.normal acc in
328            let x = aux nr fields in
329            match x with
330              | `Fail -> accu
331              | x -> (res,x) :: accu in
332          List.fold_left line []
333        in
334        { nbasic  = basic nf.basic;
335          nprod   = prod nf.prod;
336          nrecord = record nf.record;
337        }
338    
339    let collect f pp =    let collect f pp =
340      let aux accu (res,x) = (f x) :: accu in      let aux accu (res,x) = (f x) :: accu in
341      SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)      SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)
# Line 326  Line 368 
368              let accu = aux pl accu (Types.diff t ty) rem in              let accu = aux pl accu (Types.diff t ty) rem in
369              accu              accu
370      in      in
371      let pl = List.map (fun p -> p.basic) pl in      let pl = List.map (fun p -> p.nbasic) pl in
372      let tests = collect (fun x -> x) pl in      let tests = collect (fun x -> x) pl in
373      let t = Types.cap any_basic t in      let t = Types.cap any_basic t in
374      aux pl [] t tests      aux pl [] t tests
# Line 341  Line 383 
383      let aux (res,(i,q)) = (res,(i,List.assoc q success)) in      let aux (res,(i,q)) = (res,(i,List.assoc q success)) in
384      List.map (extract_unique aux)      List.map (extract_unique aux)
385    
   let prepare_prod p =  
     let line accu (res,t,pl,ql) =  
       let p = bigcap pl and q = bigcap ql in  
       let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in  
       List.fold_left aux accu (Types.Product.normal t) in  
     List.fold_left line [] p.prod  
   
386    let rec dispatch_prod t pl =    let rec dispatch_prod t pl =
387      let pl = List.map prepare_prod pl in      let pl = List.map (fun p -> p.nprod) pl in
388      let tests = collect (fun (p,_) -> p) pl in      let tests = collect (fun (p,_) -> p) pl in
389      let t = Types.Product.get t in      let t = Types.Product.get t in
390      let disp = aux_prod1 t pl [] [] [] 0 tests in      let disp = aux_prod1 t pl [] [] [] 0 tests in
# Line 392  Line 427 
427    
428  (* Record types *)  (* Record types *)
429    
   type record =  
       [ `Success  
       | `Fail  
       | `Dispatch of (nf * record) list  
       | `Label of Types.label * (nf * record) list * record ]  
430    
431    let map_record f =    let map_record f =
432      let rec aux = function      let rec aux = function
# Line 453  Line 483 
483        | _ -> assert false in        | _ -> assert false in
484      List.map aux      List.map aux
485    
   let rec cap_record nr fields =  
     match (nr,fields) with  
     | (`Success, []) -> `Success  
     | (`Fail,_) -> `Fail  
     | (`Success, (l2,pl)::fields) ->  
         `Label (l2, [bigcap pl, cap_record nr fields], `Fail)  
     | (`Label (l1, _, _), (l2,pl)::fields)  
         when l2 < l1 ->  
         `Label (l2, [bigcap pl, cap_record nr fields], `Fail)  
     | (`Label (l1, pr, _), (l2,pl)::fields)  
         when l1 = l2 ->  
         let p = bigcap pl in  
         let pr =  
           List.map (fun (t,x) -> (restrict t p, cap_record x fields)) pr in  
         `Label (l1, pr, `Fail)  
     | (`Label (l1, pr, ab),_) ->  
         let pr =  
           List.map (fun (t,x) -> (constr t, cap_record x fields)) pr in  
         `Label (l1, pr, cap_record ab fields)  
   
   
   let prepare_record =  
     map_record  
       (function (res,t,fields) ->  
          let nr = Types.Record.normal t in  
          let x = cap_record nr fields in  
          (res, [], x)  
       )  
   
   
486  (* combiner les restrict field, ... *)  (* combiner les restrict field, ... *)
487    let rec dispatch_record t pl =    let rec dispatch_record t pl =
488      let pl = prepare_record (List.map (fun p -> p.record) pl) in      let pl = List.map
489                   (fun p -> List.map (fun (res,r) -> (res,[],r)) p.nrecord
490                   ) pl in
491      let t = Types.Record.get t in      let t = Types.Record.get t in
492      aux_record1 t pl      if Types.Record.is_empty t then None else Some (aux_record1 t pl)
493    
494    and aux_record1 t pl =    and aux_record1 t pl =
495      match collect_first_label pl with      match collect_first_label pl with
# Line 527  Line 529 
529    let mask l = List.map (function None -> false | Some _ -> true) l    let mask l = List.map (function None -> false | Some _ -> true) l
530    
531    let rec dispatch (t : Types.descr) (pl : nf list) =    let rec dispatch (t : Types.descr) (pl : nf list) =
532      let pl = List.map (restrict t) pl in      let fv = List.map (fun p -> p.v) pl in
533        let pl = List.map (fun p -> normal (restrict t p)) pl in
534      let basic = dispatch_basic t pl      let basic = dispatch_basic t pl
535      and prod = dispatch_prod t pl      and prod = dispatch_prod t pl
536      and record = dispatch_record t pl in      and record = dispatch_record t pl in
# Line 540  Line 543 
543        num 0 (SortedList.from_list !accu) in        num 0 (SortedList.from_list !accu) in
544    
545      {      {
546        Dispatch.fv = List.map (fun p -> p.v) pl;        Dispatch.fv = fv;
547        Dispatch.masks = masks;        Dispatch.masks = masks;
548        Dispatch.basic = basic;        Dispatch.basic = basic;
549        Dispatch.prod = prod;        Dispatch.prod = prod;
# Line 651  Line 654 
654        (no t2 pl2);        (no t2 pl2);
655      List.iter (case_prod2 ppf pl2) cases2      List.iter (case_prod2 ppf pl2) cases2
656    
657    and show_record ppf r =    and show_record ppf = function
658        | None -> ()
659        | Some r ->
660      Format.fprintf ppf "  | Record r -> @\n";      Format.fprintf ppf "  | Record r -> @\n";
661      Format.fprintf ppf "     @[%a@]@\n" show_record_aux r      Format.fprintf ppf "     @[%a@]@\n" show_record_aux r
662    
# Line 739  Line 744 
744  #install_printer Types.Print.print_descr;;  #install_printer Types.Print.print_descr;;
745  let (t,[p1;p2]) = Patterns.NF.get 5;;  let (t,[p1;p2]) = Patterns.NF.get 5;;
746  *)  *)
747    
748    
Legend:
Removed from v.38  
changed lines
  Added in v.39
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5