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

Diff of /types/patterns.ml

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

revision 120 by abate, Tue Jul 10 17:07:48 2007 UTC revision 121 by abate, Tue Jul 10 17:08:00 2007 UTC
# Line 5  Line 5 
5    
6    
7  (* Syntactic algebra *)  (* Syntactic algebra *)
8    (* Constraint: any node except Constr has fv<>[] ... *)
9  type d =  type d =
10    | Constr of Types.node    | Constr of Types.descr
11    | Cup of descr * descr    | Cup of descr * descr
12    | Cap of descr * descr * bool    | Cap of descr * descr
13    | Times of node * node    | Times of node * node
14    | Xml of node * node    | Xml of node * node
15    | Record of Types.label * node    | Record of Types.label * node
# Line 22  Line 22 
22    fv : fv    fv : fv
23  } and descr = Types.descr * fv * d  } and descr = Types.descr * fv * d
24    
25    
26    let printed = ref []
27    let to_print = ref []
28    let rec print ppf (_,_,d) =
29      match d with
30        | Constr t -> Types.Print.print_descr ppf t
31        | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
32        | Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
33        | Times (n1,n2) ->
34            Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
35            to_print := n1 :: n2 :: !to_print
36        | Xml (n1,n2) ->
37            Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
38            to_print := n1 :: n2 :: !to_print
39        | Record (l,n) ->
40            Format.fprintf ppf "{ %s =  P%i }" (Types.LabelPool.value l) n.id;
41            to_print := n :: !to_print
42        | Capture x ->
43            Format.fprintf ppf "%s" x
44        | Constant (x,c) ->
45            Format.fprintf ppf "(%s := %a)" x Types.Print.print_const c
46    
47    
48    
49  let counter = State.ref "Patterns.counter" 0  let counter = State.ref "Patterns.counter" 0
50    
51  let make fv =  let make fv =
# Line 33  Line 57 
57    Types.define x.accept accept;    Types.define x.accept accept;
58    x.descr <- Some d    x.descr <- Some d
59    
60  let constr x = (Types.descr x,[],Constr x)  let constr x = (x,[],Constr x)
61  let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =  let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
62    if fv1 <> fv2 then (    if fv1 <> fv2 then (
63      let x = match SortedList.diff fv1 fv2 with      let x = match SortedList.diff fv1 fv2 with
# Line 46  Line 70 
70            " should appear on both side of this | pattern"))            " should appear on both side of this | pattern"))
71    );    );
72    (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))    (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
73  let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e =  let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
74    if not (SortedList.disjoint fv1 fv2) then (    if not (SortedList.disjoint fv1 fv2) then (
75      match SortedList.cap fv1 fv2 with      match SortedList.cap fv1 fv2 with
76        | x::_ ->        | x::_ ->
# Line 56  Line 80 
80                " cannot appear on both side of this & pattern"))                " cannot appear on both side of this & pattern"))
81        | _ -> assert false        | _ -> assert false
82    );    );
83    (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))    (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2))
84  let times x y =  let times x y =
85    (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))
86  let xml x y =  let xml x y =
# Line 85  Line 109 
109  let memo_filter = ref MemoFilter.empty  let memo_filter = ref MemoFilter.empty
110    
111  let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =  let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
112    (* TODO: avoid is_empty t when t is not changing (Cap) *)
113    if Types.is_empty t    if Types.is_empty t
114    then empty_res fv    then empty_res fv
115    else    else
# Line 94  Line 119 
119            SortedMap.union cup_res            SortedMap.union cup_res
120              (filter_descr (Types.cap t a) d1)              (filter_descr (Types.cap t a) d1)
121              (filter_descr (Types.diff t a) d2)              (filter_descr (Types.diff t a) d2)
122        | Cap (d1,d2,true) ->        | Cap (d1,d2) ->
123            SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)            SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
       | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->  
           SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)  
124        | Times (p1,p2) -> filter_prod fv p1 p2 t        | Times (p1,p2) -> filter_prod fv p1 p2 t
125        | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t        | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
126        | Record (l,p) ->        | Record (l,p) ->
# Line 136  Line 159 
159    
160    
161    
162    (* Returns a pattern q equivalent to p when applied to a
163       value of type t *)
164    
165    type pat =
166        Types.descr
167        * capture SortedList.t
168        * (capture, Types.const) SortedMap.t
169        * patd
170    and patd =
171      | One
172      | Zero
173      | Alt of pat * pat
174      | And of pat * pat
175      | Prod of node * node
176      | XML of node * node
177      | Rec of Types.label * node
178    
179    let rec restrict ((a,fv,d) as p) t =
180      (* TODO OPT: Don't call cup,cap .... *)
181      match d with
182        | Constr s ->
183            constr (Types.cap t a)
184            (* Could return any type  (t&s)|u  with u&t=0 *)
185        | Cup (((a1,_,_) as p1),((a2,_,_) as p2)) ->
186            let p1 =
187              if Types.is_empty (Types.cap t a1) then None
188              else Some (restrict p1 t) in
189            let p2 =
190              let t' = Types.diff t a1 in
191              if Types.is_empty (Types.cap t' a2) then None
192              else Some (restrict p2 t') in
193            (match (p1,p2) with
194               | Some p1, Some p2 -> cup p1 p2
195               | Some p1, None -> p1
196               | None, Some p2 -> p2
197               | _ -> assert false)
198        | Cap ((_,_,Constr s), p')
199        | Cap (p', (_,_,Constr s)) when Types.subtype t s -> restrict p' t
200        | Cap (p1,p2) -> cap (restrict p1 t) (restrict p2 t)
201        | Capture _ | Constant (_,_) -> p
202        | _ -> (Types.cap a t, fv, d)
203    
204    let restrict ((a,fv,_) as p) t =
205      if Types.is_empty (Types.cap a t) then `Reject
206      else if (fv = []) && (Types.subtype t a) then `Accept
207      else `Pat (restrict p t)
208    
209    
210  (* Normal forms for patterns and compilation *)  (* Normal forms for patterns and compilation *)
211    
212  module Normal =  module Normal =
# Line 315  Line 386 
386      if Types.is_empty acc      if Types.is_empty acc
387      then empty      then empty
388      else match d with      else match d with
389        | Constr t -> constr (Types.descr t)        | Constr t -> constr t
390        | Cap (p,q,_) -> cap (nf p) (nf q)        | Cap (p,q) -> cap (nf p) (nf q)
391        | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)        | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
392        | Times (p,q) -> times acc p q        | Times (p,q) -> times acc p q
393        | Xml (p,q) -> xml acc p q        | Xml (p,q) -> xml acc p q
Legend:
Removed from v.120  
changed lines
  Added in v.121
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5