Commit e200a720 authored by Pietro Abate's avatar Pietro Abate

[r2002-11-13 09:08:08 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-13 09:10:13+00:00
parent e5e0d621
......@@ -59,7 +59,7 @@ and ppat' =
| Recurs of ppat * (string * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
| And of ppat * ppat * bool
| And of ppat * ppat
| Diff of ppat * ppat
| Prod of ppat * ppat
| XmlT of ppat * ppat
......
......@@ -3,8 +3,6 @@ open Ast
(* let () = Grammar.error_verbose := true *)
let gram = Grammar.gcreate (Lexer.gmake ())
let gram = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
......@@ -90,7 +88,8 @@ EXTEND
mk loc (Try (e,b@[default]))
| "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
| "transform"; e = SELF; "with"; b = branches ->
mk noloc (Op ("flatten", [mk loc (Map (e,b))]))
let default = mk noloc (Capture "x"), cst_nil in
mk loc (Op ("flatten", [mk loc (Map (e,b@[default]))]))
| "fun"; (f,a,b) = fun_decl ->
mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
......@@ -241,8 +240,7 @@ EXTEND
-> mk loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
| "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]
| "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y,true))
(* | x = pat; ":"; y = pat -> mk loc (And (x,y,false)) *)
| "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))
| x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]
|
[ "{"; r = record_spec; "}" -> r
......@@ -304,7 +302,7 @@ EXTEND
] SEP ";" ->
match r with
| [] -> mk loc (Internal Types.Record.any)
| h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2,true))) h t
| h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
] ];
char:
......
......@@ -69,3 +69,7 @@ let fun name (Person | Man | Woman -> String)
name base;;
name (sort base);;
transform [ base base ] with
<person>[ n <children>[Person]; _] -> [n]
| _ -> [];;
......@@ -5,11 +5,11 @@ exception Error of string
(* Syntactic algebra *)
(* Constraint: any node except Constr has fv<>[] ... *)
type d =
| Constr of Types.node
| Constr of Types.descr
| Cup of descr * descr
| Cap of descr * descr * bool
| Cap of descr * descr
| Times of node * node
| Xml of node * node
| Record of Types.label * node
......@@ -22,6 +22,30 @@ and node = {
fv : fv
} and descr = Types.descr * fv * d
let printed = ref []
let to_print = ref []
let rec print ppf (_,_,d) =
match d with
| Constr t -> Types.Print.print_descr ppf t
| Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
| Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
| Times (n1,n2) ->
Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
to_print := n1 :: n2 :: !to_print
| Xml (n1,n2) ->
Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
to_print := n1 :: n2 :: !to_print
| Record (l,n) ->
Format.fprintf ppf "{ %s = P%i }" (Types.LabelPool.value l) n.id;
to_print := n :: !to_print
| Capture x ->
Format.fprintf ppf "%s" x
| Constant (x,c) ->
Format.fprintf ppf "(%s := %a)" x Types.Print.print_const c
let counter = State.ref "Patterns.counter" 0
let make fv =
......@@ -33,7 +57,7 @@ let define x ((accept,fv,_) as d) =
Types.define x.accept accept;
x.descr <- Some d
let constr x = (Types.descr x,[],Constr x)
let constr x = (x,[],Constr x)
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
if fv1 <> fv2 then (
let x = match SortedList.diff fv1 fv2 with
......@@ -46,7 +70,7 @@ let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
" should appear on both side of this | pattern"))
);
(Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e =
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
if not (SortedList.disjoint fv1 fv2) then (
match SortedList.cap fv1 fv2 with
| x::_ ->
......@@ -56,7 +80,7 @@ let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e =
" cannot appear on both side of this & pattern"))
| _ -> assert false
);
(Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
(Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2))
let times x y =
(Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
let xml x y =
......@@ -85,6 +109,7 @@ module MemoFilter = Map.Make
let memo_filter = ref MemoFilter.empty
let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
(* TODO: avoid is_empty t when t is not changing (Cap) *)
if Types.is_empty t
then empty_res fv
else
......@@ -94,10 +119,8 @@ let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
SortedMap.union cup_res
(filter_descr (Types.cap t a) d1)
(filter_descr (Types.diff t a) d2)
| Cap (d1,d2,true) ->
| Cap (d1,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)
| Times (p1,p2) -> filter_prod fv p1 p2 t
| Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
| Record (l,p) ->
......@@ -136,6 +159,54 @@ let filter t p =
(* Returns a pattern q equivalent to p when applied to a
value of type t *)
type pat =
Types.descr
* capture SortedList.t
* (capture, Types.const) SortedMap.t
* patd
and patd =
| One
| Zero
| Alt of pat * pat
| And of pat * pat
| Prod of node * node
| XML of node * node
| Rec of Types.label * node
let rec restrict ((a,fv,d) as p) t =
(* TODO OPT: Don't call cup,cap .... *)
match d with
| Constr s ->
constr (Types.cap t a)
(* Could return any type (t&s)|u with u&t=0 *)
| Cup (((a1,_,_) as p1),((a2,_,_) as p2)) ->
let p1 =
if Types.is_empty (Types.cap t a1) then None
else Some (restrict p1 t) in
let p2 =
let t' = Types.diff t a1 in
if Types.is_empty (Types.cap t' a2) then None
else Some (restrict p2 t') in
(match (p1,p2) with
| Some p1, Some p2 -> cup p1 p2
| Some p1, None -> p1
| None, Some p2 -> p2
| _ -> assert false)
| Cap ((_,_,Constr s), p')
| Cap (p', (_,_,Constr s)) when Types.subtype t s -> restrict p' t
| Cap (p1,p2) -> cap (restrict p1 t) (restrict p2 t)
| Capture _ | Constant (_,_) -> p
| _ -> (Types.cap a t, fv, d)
let restrict ((a,fv,_) as p) t =
if Types.is_empty (Types.cap a t) then `Reject
else if (fv = []) && (Types.subtype t a) then `Accept
else `Pat (restrict p t)
(* Normal forms for patterns and compilation *)
module Normal =
......@@ -315,8 +386,8 @@ struct
if Types.is_empty acc
then empty
else match d with
| Constr t -> constr (Types.descr t)
| Cap (p,q,_) -> cap (nf p) (nf q)
| Constr t -> constr t
| Cap (p,q) -> cap (nf p) (nf q)
| Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
| Times (p,q) -> times acc p q
| Xml (p,q) -> xml acc p q
......
......@@ -11,9 +11,9 @@ type node
val make: fv -> node
val define: node -> descr -> unit
val constr : Types.node -> descr
val constr : Types.descr -> descr
val cup : descr -> descr -> descr
val cap : descr -> descr -> bool -> descr
val cap : descr -> descr -> descr
val times : node -> node -> descr
val xml : node -> node -> descr
......
......@@ -28,7 +28,7 @@ and descr =
[ `Alias of string * ti
| `Type of Types.descr
| `Or of ti * ti
| `And of ti * ti * bool
| `And of ti * ti
| `Diff of ti * ti
| `Times of ti * ti
| `Xml of ti * ti
......@@ -109,7 +109,7 @@ module Regexp = struct
| WeakStar r -> `WeakStar (propagate vars r)
| SeqCapture (v,x) ->
let v= mk !re_loc (Capture v) in
propagate (fun p -> mk !re_loc (And (vars p,v,true))) x
propagate (fun p -> mk !re_loc (And (vars p,v))) x
let cup r1 r2 =
match (r1,r2) with
......@@ -160,8 +160,7 @@ module Regexp = struct
let constant_nil v t =
mk !re_loc
(And (t,
(mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom))), true))
(And (t, (mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))
let compile loc regexp queue : ppat =
re_loc := loc;
......@@ -188,7 +187,7 @@ let rec compile env { loc = loc; descr = d } : ti =
| Regexp (r,q) -> compile env (Regexp.compile loc r q)
| Internal t -> cons loc (`Type t)
| Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
| And (t1,t2,e) -> cons loc (`And (compile env t1, compile env t2,e))
| And (t1,t2) -> cons loc (`And (compile env t1, compile env t2))
| Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
| Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
| XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))
......@@ -216,7 +215,7 @@ let rec comp_fv s =
(match s.descr' with
| `Alias (_,x) -> comp_fv x
| `Or (s1,s2)
| `And (s1,s2,_)
| `And (s1,s2)
| `Diff (s1,s2)
| `Times (s1,s2) | `Xml (s1,s2)
| `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
......@@ -249,18 +248,13 @@ let rec typ seen s : Types.descr =
else typ (s :: seen) x
| `Type t -> t
| `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
| `And (s1,s2,_) -> Types.cap (typ seen s1) (typ seen s2)
| `And (s1,s2) -> Types.cap (typ seen s1) (typ seen s2)
| `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
| `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
| `Xml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2)
| `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
| `Record (l,o,s) -> Types.record l o (typ_node s)
| `Capture x -> failwith ("bla1:" ^ x)
| `Constant (x,_) ->
(match s.fv with
| Some fv ->
List.iter (fun y -> Printf.eprintf "+++%s++++\n" y) fv);
failwith ("bla:" ^ x); assert false
| `Capture x | `Constant (x,_) -> assert false
and typ_node s : Types.node =
match s.type_node with
......@@ -279,7 +273,7 @@ let type_node s =
s
let rec pat seen s : Patterns.descr =
if fv s = [] then Patterns.constr (type_node s) else
if fv s = [] then Patterns.constr (Types.descr (type_node s)) else
try pat_aux seen s
with Patterns.Error e -> raise_loc_generic s.loc' e
| Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))
......@@ -293,10 +287,10 @@ and pat_aux seen s = match s.descr' with
("Unguarded recursion on variable " ^ v ^ " in this pattern"));
pat (s :: seen) x
| `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
| `And (s1,s2,e) -> Patterns.cap (pat seen s1) (pat seen s2) e
| `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
| `Diff (s1,s2) when fv s2 = [] ->
let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
Patterns.cap (pat seen s1) (Patterns.constr s2) true
let s2 = Types.neg (Types.descr (type_node s2)) in
Patterns.cap (pat seen s1) (Patterns.constr s2)
| `Diff _ ->
raise (Patterns.Error "Difference not allowed in patterns")
| `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment