Commit 9f9826f5 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-10 22:26:37 by cvscast] Passage au type XML

Original author: cvscast
Date: 2002-11-10 22:26:39+00:00
parent 6085e08a
......@@ -6,7 +6,7 @@ let eval_env = Eval.global_env
let print_norm ppf d =
Location.protect ppf
(fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
(fun ppf -> Types.Print.print_descr ppf (Types.normalize d))
let print_value ppf v =
Location.protect ppf (fun ppf -> Value.print ppf v)
......
......@@ -170,7 +170,6 @@ let main (cgi : Netcgi.std_activation) =
Location.set_source (`String src);
Load_xml.set_auth false;
load_state ();
let ok = Cduce.run ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n";
let res = Format.flush_str_formatter () in
......@@ -180,8 +179,6 @@ let main (cgi : Netcgi.std_activation) =
let dump src =
let ppf = Format.str_formatter in
load_state ();
store_state (); (* Just touch the file ... *)
Format.fprintf ppf "<b>Environment</b>:@.";
Cduce.dump_env ppf;
......@@ -192,6 +189,8 @@ let main (cgi : Netcgi.std_activation) =
in
Location.set_viewport `Html;
load_state ();
store_state (); (* Just touch the file ... *)
html_header p;
let prog = cgi # argument_value "prog" in
(match cmd with
......
......@@ -31,6 +31,7 @@ and pexpr' =
(* Data constructors *)
| Cst of Types.const
| Pair of pexpr * pexpr
| Xml of pexpr * pexpr
| RecordLitt of (Types.label * pexpr) list
(* Data destructors *)
......@@ -61,6 +62,7 @@ and ppat' =
| And of ppat * ppat * bool
| Diff of ppat * ppat
| Prod of ppat * ppat
| XmlT of ppat * ppat
| Arrow of ppat * ppat
| Record of Types.label * bool * ppat
| Capture of Patterns.capture
......
......@@ -137,11 +137,10 @@ EXTEND
mk loc (Cst (Types.Atom (Types.AtomPool.mk a)))
| "<"; e = expr LEVEL "no_appl" -> e ];
a = expr_attrib_spec; ">"; c = expr ->
tuple loc [t;a;c]
mk loc (Xml (t, mk loc (Pair (a,c))))
| "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
| s = STRING2 ->
tuple loc (char_list loc s @ [cst_nil])
(* | "!"; t = pat -> mk loc (DebugTyper t) *)
| a = LIDENT -> mk loc (Var a)
]
......@@ -281,7 +280,7 @@ EXTEND
| [ "<"; t = pat -> t ]
];
a = attrib_spec; ">"; c = pat ->
multi_prod loc [t;a;c]
mk loc (XmlT (t, multi_prod loc [a;c]))
| s = STRING2 ->
let s = seq_of_string loc s in
let s = List.map
......
......@@ -47,6 +47,7 @@ let rec eval env e0 =
*)
| Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Xml (e1,e2) -> Xml (eval env e1, eval env e2)
| Typed.Cst c -> const c
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
......
......@@ -40,7 +40,7 @@ let run s =
let att = SortedMap.from_list (fun _ _ -> assert false) att in
let child = parse_seq () in
let elt = Pair
let elt = Xml
(Atom (Types.AtomPool.mk name),
Pair (Record att, child)
) in
......
......@@ -49,6 +49,7 @@ let rec run_dispatcher d v =
and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
| Xml (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.xml
| Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
| Atom a ->
run_disp_basic v (fun t -> Types.Atom.has_atom t a)
......
type t =
| Pair of t * t
| Xml of t * t
| Record of (Types.label,t) SortedMap.t
| Atom of Types.atom
| Integer of Big_int.big_int
......@@ -48,10 +49,10 @@ let rec is_str = function
let rec print ppf v =
if is_str v then Format.fprintf ppf "\"%a\"" print_quoted_str v
else if is_xml v then print_xml ppf v
else if is_seq v then Format.fprintf ppf "[ %a]" print_seq v
else match v with
| Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
| Xml (x,y) -> print_xml ppf (x,y)
| Record l -> Format.fprintf ppf "{%a }" print_record l
| Atom a -> Format.fprintf ppf "`%s" (Types.AtomPool.value a)
| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
......@@ -87,7 +88,7 @@ and print_str ppf = function
print_seq ppf v
and print_xml ppf = function
| Pair(Atom tag, Pair (Record attr,content)) ->
| (Atom tag, Pair (Record attr,content)) ->
Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]"
(Types.AtomPool.value tag)
print_record attr
......
type t =
(* Canonical representation *)
| Pair of t * t
| Xml of t * t
| Record of (Types.label,t) SortedMap.t
| Atom of Types.atom
| Integer of Big_int.big_int
......
......@@ -18,14 +18,14 @@ type Mix = <h1>[Mix*]
let fun do_authors ([Author+] -> [Mix*])
| [ <author>a ] -> a
| [ <author>a <author>b ] -> a " and, " b
| [ <author>a; x] -> a ", " (do_authors x);;
| [ <author>a <author>b ] -> a @ " and, " @ b
| [ <author>a; x] -> a @ ", " @ (do_authors x);;
let fun do_paper (Paper -> <li>[Mix*])
<paper>[ x::(_* ) <title>t <conference>c <file>f ] ->
(* Here, type inference says: x : [Author+] ... *)
let authors = do_authors x in
<li>([ <a href=f>t ] authors "; in " [ <em>c ] "." );;
<li>([ <a href=f>t ] @ authors @ "; in " @ [ <em>c ] @ "." );;
let fun do_biblio (Biblio -> Html)
<bibliography>[ <heading>h; p ] ->
......
......@@ -26,4 +26,4 @@ let base : Person =
]
]
]
in sort 3;;
in sort base;;
......@@ -33,6 +33,10 @@ let contains x = function
let is_empty = function
| Finite [] -> true
| _ -> false
let is_atom = function
| Finite [a] -> Some a
| _ -> None
let sample except = function
| Finite (x :: _) -> x
......
......@@ -10,6 +10,7 @@ val atom : 'a -> 'a t
val contains : 'a -> 'a t -> bool
val is_empty : 'a t -> bool
val is_atom : 'a t -> 'a option
val sample : ('a list -> 'a) -> 'a t -> 'a
val print : string -> (Format.formatter -> 'a -> unit) -> 'a t ->
......
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
type capture = string
type fv = capture SortedList.t
......@@ -17,6 +11,7 @@ type d =
| Cup of descr * descr
| Cap of descr * descr * bool
| Times of node * node
| Xml of node * node
| Record of Types.label * node
| Capture of capture
| Constant of capture * Types.const
......@@ -64,6 +59,8 @@ let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e =
(Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
let times x y =
(Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
let xml x y =
(Types.xml x.accept y.accept, SortedList.cup x.fv y.fv, Xml (x,y))
let record l x =
(Types.record l false x.accept, x.fv, Record (l,x))
let capture x = (Types.any, [x], Capture x)
......@@ -101,18 +98,8 @@ let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
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) ->
List.fold_left
(fun accu (d1,d2) ->
let term =
SortedMap.union times_res
(filter_node d1 p1)
(filter_node d2 p2)
in
SortedMap.union cup_res accu term
)
(empty_res fv)
(Types.Product.normal t)
| Times (p1,p2) -> filter_prod fv p1 p2 t
| Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
| Record (l,p) ->
filter_node (Types.Record.project t l) p
| Capture c ->
......@@ -120,6 +107,18 @@ let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
| Constant (c, cst) ->
[(c, Types.Positive.ty (Types.constant cst))]
and filter_prod ?kind fv p1 p2 t =
List.fold_left
(fun accu (d1,d2) ->
let term =
SortedMap.union times_res (filter_node d1 p1) (filter_node d2 p2)
in
SortedMap.union cup_res accu term
)
(empty_res fv)
(Types.Product.normal ?kind t)
and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
try MemoFilter.find (t,p) !memo_filter
with Not_found ->
......@@ -158,7 +157,9 @@ struct
a : Types.descr;
basic : unit line;
prod : (node sl * node sl) line;
record: ((Types.label, node sl) sm) line
xml : (node sl * node sl) line;
record: ((Types.label, node sl) sm) line;
}
type 'a nline = (result * 'a) list
......@@ -173,15 +174,17 @@ struct
na : Types.descr;
nbasic : Types.descr nline;
nprod : (nf * nf) nline;
nxml : (nf * nf) nline;
nrecord: record nline
}
let empty = { v = []; catchv = [];
a = Types.empty;
basic = []; prod = []; record = [] }
let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)
basic = []; prod = []; xml = []; record = [] }
let any_basic = Types.neg (List.fold_left Types.cup Types.empty
[Types.Product.any_xml;
Types.Product.any;
Types.Record.any])
let restrict t nf =
let rec filter = function
| (key,acc) :: rem ->
......@@ -194,6 +197,7 @@ struct
a = Types.cap t nf.a;
basic = filter nf.basic;
prod = filter nf.prod;
xml = filter nf.xml;
record = filter nf.record;
}
......@@ -222,6 +226,7 @@ struct
a = Types.cap nf1.a nf2.a;
basic = merge merge_basic nf1.basic nf2.basic;
prod = merge merge_prod nf1.prod nf2.prod;
xml = merge merge_prod nf1.xml nf2.xml;
record = merge merge_record nf1.record nf2.record;
}
......@@ -234,6 +239,7 @@ struct
a = Types.cup nf1.a nf2.a;
basic = SortedMap.union Types.cup nf1.basic nf2.basic;
prod = SortedMap.union Types.cup nf1.prod nf2.prod;
xml = SortedMap.union Types.cup nf1.xml nf2.xml;
record = SortedMap.union Types.cup nf1.record nf2.record;
}
......@@ -246,6 +252,15 @@ struct
a = acc;
prod = [ (src, ([p], [q])), acc ] }
let xml acc p q =
let src_p = List.map (fun v -> (v,`Left)) p.fv
and src_q = List.map (fun v -> (v,`Right)) q.fv in
let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in
{ empty with
v = SortedList.cup p.fv q.fv;
a = acc;
xml = [ (src, ([p], [q])), acc ] }
let record acc l p =
let src = List.map (fun v -> (v, `Field l)) p.fv in
{ empty with
......@@ -259,6 +274,7 @@ struct
a = Types.any;
basic = [ ([],()), any_basic ];
prod = [ ([],([],[])), Types.Product.any ];
xml = [ ([],([],[])), Types.Product.any_xml ];
record = [ ([],[]), Types.Record.any ];
}
......@@ -269,6 +285,7 @@ struct
a = Types.any;
basic = [ (l,()), any_basic ];
prod = [ (l,([],[])), Types.Product.any ];
xml = [ (l,([],[])), Types.Product.any_xml ];
record = [ (l,[]), Types.Record.any ];
}
......@@ -279,6 +296,7 @@ struct
a = Types.any;
basic = [ (l,()), any_basic ];
prod = [ (l,([],[])), Types.Product.any ];
xml = [ (l,([],[])), Types.Product.any_xml ];
record = [ (l,[]), Types.Record.any ];
}
......@@ -288,6 +306,7 @@ struct
a = t;
basic = [ ([],()), Types.cap t any_basic ];
prod = [ ([],([],[])), Types.cap t Types.Product.any ];
xml = [ ([],([],[])), Types.cap t Types.Product.any_xml ];
record = [ ([],[]), Types.cap t Types.Record.any ];
}
......@@ -300,6 +319,7 @@ struct
| 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
| Capture x -> capture x
| Constant (x,c) -> constant x c
| Record (l,p) -> record acc l p
......@@ -310,13 +330,13 @@ struct
let basic =
List.map (fun ((res,()),acc) -> (res,acc))
and prod =
and prod ?kind l =
let line accu (((res,(pl,ql)),acc)) =
let p = bigcap pl and q = bigcap ql in
let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
let t = Types.Product.normal acc in
let t = Types.Product.normal ?kind acc in
List.fold_left aux accu t in
List.fold_left line []
List.fold_left line [] l
and record =
......@@ -359,6 +379,7 @@ struct
na = nf.a;
nbasic = nlines (basic nf.basic);
nprod = nlines (prod nf.prod);
nxml = nlines (prod ~kind:`XML nf.xml);
nrecord = nlines (record nf.record);
}
......@@ -373,6 +394,7 @@ struct
and actions_kind = {
basic: (Types.descr * result) list;
prod: result dispatch dispatch;
xml: result dispatch dispatch;
record: record option;
}
and record =
......@@ -425,7 +447,7 @@ struct
in
aux f a 0
let combine_kind basic prod record =
let combine_kind basic prod xml record =
try (
let rs = [] in
let rs = match basic with
......@@ -436,6 +458,10 @@ struct
| `None -> rs
| `Ignore (`Ignore r) -> r :: rs
| _ -> raise Exit in
let rs = match xml with
| `None -> rs
| `Ignore (`Ignore r) -> r :: rs
| _ -> raise Exit in
let rs = match record with
| None -> rs
| Some (`Result r) -> r :: rs
......@@ -448,7 +474,7 @@ struct
-> `Ignore r
| _ -> raise Exit
)
with Exit -> `Kind { basic = basic; prod = prod; record = record }
with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }
let combine (disp,act) =
if Array.length act = 0 then `None
......@@ -550,7 +576,8 @@ struct
| `None -> ()
| `Switch (pos, yes, no) ->
aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no
| `Result (code,t,arity) -> codes.(code) <- (t,arity, accu)
| `Result (code,t,arity) ->
codes.(code) <- (t,arity, accu)
in
aux 0 [] iface;
let res = { id = !cur_id;
......@@ -576,7 +603,8 @@ struct
let find_code d a =
let rec aux i = function
| `Result (code,_,_) -> code
| `None -> assert false
| `None ->
assert false
| `Switch (_,yes,no) ->
match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no
in
......@@ -698,9 +726,13 @@ struct
(fun x -> x)
let rec dispatch_prod disp =
let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in
let t = Types.Product.get disp.t in
let rec dispatch_prod ?(kind=`Normal) disp =
let pl =
match kind with
| `Normal -> Array.map (fun p -> p.Normal.nprod) disp.pl
| `XML -> Array.map (fun p -> p.Normal.nxml) disp.pl
in
let t = Types.Product.get ~kind disp.t in
get_tests pl
(fun (res,(p,q)) -> [p, (res,q)], [])
(Types.Product.pi1 t)
......@@ -852,6 +884,7 @@ struct
let a = combine_kind
(dispatch_basic disp)
(dispatch_prod disp)
(dispatch_prod ~kind:`XML disp)
(dispatch_record disp)
in
disp.actions <- Some a;
......@@ -925,18 +958,18 @@ struct
)
branches
in
let print_prod = function
let print_prod prefix = function
| `None -> ()
| `Ignore d2 ->
Format.fprintf ppf " | (v1,v2) -> @\n";
Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
print_prod2 d2
| `TailCall d ->
queue d;
Format.fprintf ppf " | (v1,v2) -> @\n";
Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
Format.fprintf ppf " disp_%i v1@\n" d.id
| `Dispatch (d,branches) ->
queue d;
Format.fprintf ppf " | (v1,v2) -> @\n";
Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
Format.fprintf ppf " match v1 with disp_%i@\n" d.id;
Array.iteri
(fun code d2 ->
......@@ -984,7 +1017,8 @@ struct
in
List.iter print_basic actions.basic;
print_prod actions.prod;
print_prod "" actions.prod;
print_prod "XML" actions.xml;
print_record_opt ppf actions.record
let print_actions ppf = function
......
......@@ -16,6 +16,7 @@ val cup : descr -> descr -> descr
val cap : descr -> descr -> bool -> descr
val times : node -> node -> descr
val xml : node -> node -> descr
val record : Types.label -> node -> descr
val capture : capture -> descr
......@@ -45,6 +46,7 @@ module Compile: sig
and actions_kind = {
basic: (Types.descr * result) list;
prod: result dispatch dispatch;
xml: result dispatch dispatch;
record: record option;
}
and record =
......
This diff is collapsed.
......@@ -39,9 +39,12 @@ val any : descr
(** Constructors **)
type pair_kind = [ `Normal | `XML ]
val interval : Intervals.t -> descr
val atom : atom Atoms.t -> descr
val times : node -> node -> descr
val xml : node -> node -> descr
val arrow : node -> node -> descr
val record : label -> bool -> node -> descr
val char : Chars.t -> descr
......@@ -65,13 +68,14 @@ end
module Product : sig
val any : descr
val other : descr -> descr
val is_product : descr -> bool
val any_xml : descr
val other : ?kind:pair_kind -> descr -> descr
val is_product : ?kind:pair_kind -> descr -> bool
(* List of non-empty rectangles *)
type t = (descr * descr) list
val is_empty: t -> bool
val get: descr -> t
val get: ?kind:pair_kind -> descr -> t
val pi1: t -> descr
val pi2: t -> descr
......@@ -81,7 +85,7 @@ module Product : sig
(* List of non-empty rectangles whose first projection
are pair-wise disjunct *)
type normal = t
val normal: descr -> normal
val normal: ?kind:pair_kind -> descr -> normal
val need_second: t -> bool
(* Is there more than a single rectangle ? *)
......@@ -177,7 +181,8 @@ sig
| Int of Big_int.big_int
| Atom of atom
| Char of Chars.Unichar.t
| Pair of t * t
| Pair of (t * t)
| Xml of (t * t)
| Record of (label * t) list
| Fun of (node * node) list
......
......@@ -28,6 +28,7 @@ and texpr' =
(* Data constructors *)
| Cst of Types.const
| Pair of texpr * texpr
| Xml of texpr * texpr
| RecordLitt of (Types.label, texpr) SortedMap.t
(* Data destructors *)
......
......@@ -31,6 +31,7 @@ and descr =
| `And of ti * ti * bool
| `Diff of ti * ti
| `Times of ti * ti
| `Xml of ti * ti
| `Arrow of ti * ti
| `Record of Types.label * bool * ti
| `Capture of Patterns.capture
......@@ -190,6 +191,7 @@ let rec compile env { loc = loc; descr = d } : ti =
| And (t1,t2,e) -> cons loc (`And (compile env t1, compile env t2,e))
| 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))
| Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
| Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
| Constant (x,v) -> cons loc (`Constant (x,v))
......@@ -213,7 +215,7 @@ let rec comp_fv s =
| `Or (s1,s2)
| `And (s1,s2,_)
| `Diff (s1,s2)
| `Times (s1,s2)
| `Times (s1,s2) | `Xml (s1,s2)
| `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
| `Record (l,opt,s) -> comp_fv s
| `Type _ -> ()
......@@ -248,6 +250,7 @@ let rec typ seen s : Types.descr =
| `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)