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

Diff of /types/patterns.ml

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

revision 148 by abate, Tue Jul 10 17:10:28 2007 UTC revision 149 by abate, Tue Jul 10 17:10:34 2007 UTC
# Line 684  Line 684 
684    
685  (* Normal forms for patterns and compilation *)  (* Normal forms for patterns and compilation *)
686    
687  module Normal =  module Normal : sig
688      type 'a sl = 'a SortedList.t
689      type ('a,'b) sm = ('a,'b) SortedMap.t
690    
691      type source =
692          [ `Catch | `Const of Types.const
693          | `Left | `Right | `Recompose
694          | `Field of Types.label
695          ]
696      type result = (capture, source) sm
697    
698      type nnf = node sl * Types.descr
699      type 'a nline = (result *  'a) list
700      type record =
701          [ `Success
702          | `Fail
703          | `Dispatch of (nnf * record) list
704          | `Label of Types.label * (nnf * record) list * record ]
705      type t = {
706        nfv    : fv;
707        ncatchv: fv;
708        na     : Types.descr;
709        nbasic : Types.descr nline;
710        nprod  : (nnf * nnf) nline;
711        nxml   : (nnf * nnf) nline;
712        nrecord: record nline
713      }
714    
715      val any_basic: Types.descr
716      val normal: Types.descr -> node list -> t
717    end =
718  struct  struct
719    type 'a sl = 'a SortedList.t    type 'a sl = 'a SortedList.t
720    type ('a,'b) sm = ('a,'b) SortedMap.t    type ('a,'b) sm = ('a,'b) SortedMap.t
# Line 707  Line 737 
737      record: ((Types.label, node sl) sm) line;      record: ((Types.label, node sl) sm) line;
738    
739    }    }
740    type nnf = Types.descr * node sl  
741    type 'a nline = (result *  'a) list    type nnf = node sl * Types.descr   (* pl,t;   t <= \accept{pl} *)
742      type 'a nline = (result *  'a) sl
743    type record =    type record =
744        [ `Success        [ `Success
745        | `Fail        | `Fail
# Line 724  Line 755 
755      nrecord: record nline      nrecord: record nline
756    }    }
757    
758      let nempty = { nfv = []; ncatchv = []; na = Types.empty;
759                     nbasic = []; nprod = []; nxml = []; nrecord = [] }
760    
761    
762      let ncup nf1 nf2 =
763        (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
764        (* assert (nf1.nfv = nf2.nfv); *)
765        { nfv = nf1.nfv;
766          ncatchv = SortedList.cap nf1.ncatchv nf2.ncatchv;
767          na      = Types.cup nf1.na nf2.na;
768          nbasic  = SortedList.cup nf1.nbasic nf2.nbasic;
769          nprod   = SortedList.cup nf1.nprod nf2.nprod;
770          nxml    = SortedList.cup nf1.nxml nf2.nxml;
771          nrecord = SortedList.cup nf1.nrecord nf2.nrecord;
772        }
773    
774      let fus = SortedMap.union_disj
775      let slcup = SortedList.cup
776    
777      let double_fold f l1 l2 =
778        SortedList.from_list
779          (List.fold_left
780             (fun accu x1 ->
781                List.fold_left
782                (fun accu x2 ->
783                   f accu x1 x2
784                )
785                accu l2
786             ) [] l1)
787    
788      let ncap nf1 nf2 =
789        let prod accu (res1,((pl1,t1),(ql1,s1))) (res2,((pl2,t2),(ql2,s2))) =
790          let t = Types.cap t1 t2 in
791          if Types.is_empty t then accu else
792            let s = Types.cap s1 s2  in
793            if Types.is_empty s then accu else
794              (fus res1 res2, ((slcup pl1 pl2,t),(slcup ql1 ql2,s))) :: accu
795        in
796        let basic accu (res1,t1) (res2,t2) =
797          let t = Types.cap t1 t2 in
798          if Types.is_empty t then accu else
799            (fus res1 res2, t) :: accu
800        in
801        { nfv = SortedList.cup nf1.nfv nf2.nfv;
802          ncatchv = SortedList.cup nf1.ncatchv nf2.ncatchv;
803          na = Types.cap nf1.na nf2.na;
804          nbasic = double_fold basic nf1.nbasic nf2.nbasic;
805          nprod = double_fold prod nf1.nprod nf2.nprod;
806          nxml = double_fold prod nf1.nxml nf2.nxml;
807          nrecord = []; (* TODO ... *)
808        }
809    
810      let ntimes acc p q =
811        let src_p = List.map (fun v -> (v,`Left)) p.fv
812        and src_q = List.map (fun v -> (v,`Right)) q.fv in
813        let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in
814        let rects = Types.Product.normal acc in
815        let prod = List.map (fun (t1,t2) -> (src, (([p],t1),([q],t2)))) rects in
816        { nempty with
817            nfv = SortedList.cup p.fv q.fv;
818            na = acc;
819            nprod = SortedList.from_list prod
820        }
821    
822    
823    
824    let empty = { v = []; catchv = [];    let empty = { v = []; catchv = [];
825                  a = Types.empty;                  a = Types.empty;
826                  basic = []; prod = []; xml = []; record = [] }                  basic = []; prod = []; xml = []; record = [] }
# Line 747  Line 844 
844         record = filter nf.record;         record = filter nf.record;
845      }      }
846    
   let fus = SortedMap.union_disj  
   let slcup = SortedList.cup  
847    
848    let cap nf1 nf2 =    let cap nf1 nf2 =
849      let merge f lines1 lines2 =      let merge f lines1 lines2 =
# Line 870  Line 965 
965        | Constant (x,c) -> constant x c        | Constant (x,c) -> constant x c
966        | Record (l,p) -> record acc l p        | Record (l,p) -> record acc l p
967    
   let bigcap pl = pl (* List.fold_left (fun a p -> cap a (nf (descr p))) any *)  
   
968    let normal nf =    let normal nf =
969      let basic =      let basic =
970        List.map (fun ((res,()),acc) -> (res,acc))        List.map (fun ((res,()),acc) -> (res,acc))
971    
972      and prod ?kind l =      and prod ?kind l =
973        let line accu (((res,(pl,ql)),acc)) =        let line accu (((res,(pl,ql)),acc)) =
974          let aux accu (t1,t2) = (res,( (t1,pl), (t2,ql) ))::accu in          let aux accu (t1,t2) = (res,( (pl,t1), (ql,t2) ))::accu in
975          let t = Types.Product.normal ?kind acc in          let t = Types.Product.normal ?kind acc in
976          List.fold_left aux accu t in          List.fold_left aux accu t in
977        List.fold_left line [] l        List.fold_left line [] l
# Line 890  Line 983 
983            | (`Success, []) -> `Success            | (`Success, []) -> `Success
984            | (`Fail,_) -> `Fail            | (`Fail,_) -> `Fail
985            | (`Success, (l2,pl)::fields) ->            | (`Success, (l2,pl)::fields) ->
986                `Label (l2, [(Types.any,pl), aux nr fields], `Fail)                `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
987            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
988                `Label (l2, [(Types.any,pl), aux nr fields], `Fail)                `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
989            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
990                let pr =                let pr =
991                  List.map (fun (t,x) -> ((t,pl), aux x fields)) pr in                  List.map (fun (t,x) -> (((pl,t) : nnf), aux x fields)) pr in
992                `Label (l1, pr, `Fail)                `Label (l1, pr, `Fail)
993            | (`Label (l1, pr, ab),_) ->            | (`Label (l1, pr, ab),_) ->
994                let aux_ab = aux ab fields in                let aux_ab = aux ab fields in
995                let pr =                let pr =
996                  List.map (fun (t,x) -> ((t,[]),                  List.map (fun (t,x) -> (([],t),
997  (* Types.Record.normal enforce physical equility  (* Types.Record.normal enforce physical equility
998     in case of a ? field *)     in case of a ? field *)
999                                          if x==ab then aux_ab else                                          if x==ab then aux_ab else
# Line 927  Line 1020 
1020        nrecord = nlines (record nf.record);        nrecord = nlines (record nf.record);
1021      }      }
1022    
1023      let normal t pl =
1024        normal (List.fold_left (fun a p -> cap a (nf (descr p))) (constr t) pl)
1025    
1026  end  end
1027    
1028    
# Line 1195  Line 1291 
1291      let unselect = Array.create (Array.length pl) [] in      let unselect = Array.create (Array.length pl) [] in
1292      let aux i x =      let aux i x =
1293        let yes, no = f x in        let yes, no = f x in
1294        List.iter (fun ( (ty,pl), info) ->        List.iter (fun ( (pl,ty), info) ->
1295                     let p =                     let p = Normal.normal ty pl in
                      List.fold_left (fun a p -> Normal.cap a  
                                        (Normal.nf (descr p)))  
                        (Normal.constr ty) pl in  
   
                    let p = Normal.restrict t p in  
                    let p = Normal.normal p in  
1296                     accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;                     accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
1297                  ) yes;                  ) yes;
1298        unselect.(i) <- no @ unselect.(i) in        unselect.(i) <- no @ unselect.(i) in
# Line 1225  Line 1315 
1315      let (_,brs) =      let (_,brs) =
1316        List.fold_left        List.fold_left
1317          (fun (t,brs) (p,e) ->          (fun (t,brs) (p,e) ->
1318             let p' = (t,[p]) in             let p' = ([p],t) in
1319             let t' = Types.diff t (Types.descr (accept p)) in             let t' = Types.diff t (Types.descr (accept p)) in
1320             (t', (p',e) :: brs)             (t', (p',e) :: brs)
1321          ) (t,[]) brs in          ) (t,[]) brs in
# Line 1590  Line 1680 
1680      queue disp;      queue disp;
1681      print_dispatchers ppf      print_dispatchers ppf
1682    
1683    type normal = Normal.t    let debug_compile ppf t pl =
1684    let normal p = Normal.normal (Normal.nf p)      let pl = Array.of_list
1685                   (List.map (fun p -> Normal.normal Types.any [p]) pl) in
1686        let t = Types.descr t in
1687        show ppf t pl
1688  end  end
1689    
1690    
Legend:
Removed from v.148  
changed lines
  Added in v.149
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5