Skip to content

GitLab

Commit 452a2518 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-01-07 15:26:07 by afrisch] Demo 

Original author: afrisch
Date: 2005-01-07 15:26:09+00:00
parent 07d281d1
Show whitespace changes
Inline Side-by-side
runtime/run_dispatch.ml
View file @ 452a2518
......@@ -41,7 +41,6 @@ let push v =
(* Old dispatchers *)
let make_result_prod v1 r1 v2 r2 v (code,r) =
let n = Array.length r in
if n == 0 then code else (
......@@ -52,11 +51,13 @@ let make_result_prod v1 r1 v2 r2 v (code,r) =
let x = match Array.unsafe_get r a with
| Catch -> v
| Const c -> const c
| Left i -> if (i < 0) then v1 else buf.(r1 + i)
| Right j -> if (j < 0) then v2 else buf.(r2 + j)
| Left i -> (match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(r1+i))
| Right j -> (match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(r2+j))
| Recompose (i,j) ->
Pair ((if (i < 0) then v1 else buf.(r1 + i)),
(if (j < 0) then v2 else buf.(r2 + j)))
Pair (
(match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(r1+i)),
(match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(r2+j))
)
in
buf.(c + a) <- x
done;
......@@ -109,11 +110,25 @@ let make_result_string_latin1 i j s q r1 r2 (code,r) =
let x = match Array.unsafe_get r a with
| Catch -> String_latin1 (i,j,s,q)
| Const c -> const c
| Left n -> if (n < 0) then Char (Chars.V.mk_char s.[i]) else buf.(r1 + n)
| Right m -> if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m)
| Left n -> (match n with
| (-1) -> Char (Chars.V.mk_char s.[i])
| (-2) -> nil
| _ -> buf.(r1+n))
| Right m -> (match m with
| (-1) -> tail_string_latin1 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
| Recompose (n,m) ->
Pair ((if (n < 0) then Char (Chars.V.mk_char s.[i]) else buf.(r1 + n)),
(if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m)))
Pair (
(match n with
| (-1) -> Char (Chars.V.mk_char s.[i])
| (-2) -> nil
| _ -> buf.(r1+n)),
(match m with
| (-1) -> tail_string_latin1 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
)
in
buf.(!cursor + a) <- x
done;
......@@ -134,11 +149,25 @@ let make_result_string_utf8 i j s q r1 r2 (code,r) =
let x = match Array.unsafe_get r a with
| Catch -> String_utf8 (i,j,s,q)
| Const c -> const c
| Left n -> if (n < 0) then Char (Chars.V.mk_int (Utf8.get s i)) else buf.(r1 + n)
| Right m -> if (m < 0) then tail_string_utf8 i j s q else buf.(r2 + m)
| Left n -> (match n with
| (-1) -> Char (Chars.V.mk_int (Utf8.get s i))
| (-2) -> nil
| _ -> buf.(r1+n))
| Right m -> (match m with
| (-1) -> tail_string_utf8 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
| Recompose (n,m) ->
Pair ((if (n < 0) then Char (Chars.V.mk_int (Utf8.get s i)) else buf.(r1 + n)),
(if (m < 0) then tail_string_utf8 i j s q else buf.(r2 + m)))
Pair (
(match n with
| (-1) -> Char (Chars.V.mk_int (Utf8.get s i))
| (-2) -> nil
| _ -> buf.(r1+n)),
(match m with
| (-1) -> tail_string_utf8 i j s q
| (-2) -> nil
| _ -> buf.(r2+m))
)
in
buf.(!cursor + a) <- x
done;
......
types/patterns.ml
View file @ 452a2518
......@@ -904,35 +904,35 @@ module Normal = struct
IdSet.empty
pl
let normal l t pl xs =
let normal f l t pl xs =
let a = nconstr l t in
let vs = facto Factorize.var t xs pl in
let xs = IdSet.diff xs vs in
let a = List.fold_left (fun a x -> ncap a (ncapture l x)) a vs in
let vs = facto Factorize.nil t xs pl in
(*
let ppf = Format.std_formatter in
Format.fprintf ppf "t = %a xs = %a"
Types.Print.print t
Print.print_xs xs;
List.iter (fun p -> Format.fprintf ppf "p:%a " Print.print (descr p)) pl;
Format.fprintf ppf " => %a@."
Print.print_xs vs;
*)
let xs = IdSet.diff xs vs in
let a = List.fold_left (fun a x -> ncap a (nconstant l x Sequence.nil_cst)) a vs in
let vs_var = facto Factorize.var t xs pl in
let xs = IdSet.diff xs vs_var in
let vs_var,a =
if f then vs_var,a
else
IdSet.empty,
List.fold_left (fun a x -> ncap a (ncapture l x)) a vs_var in
let vs_nil = facto Factorize.nil t xs pl in
let xs = IdSet.diff xs vs_nil in
let vs_nil,a =
if f then vs_nil,a
else
IdSet.empty,
List.fold_left
(fun a x -> ncap a (nconstant l x Sequence.nil_cst)) a vs_nil in
vs_var,vs_nil,
List.fold_left (fun a p -> ncap a (nnormal l (descr p) xs)) a pl
let nnf lab t0 (pl,t,xs) =
let nnf facto lab t0 (pl,t,xs) =
let t =
if Types.subtype t t0 then t else Types.cap t t0 in
(* let ppf = Format.std_formatter in
Format.fprintf ppf "normal nnf=%a@." Nnf.print (pl,t,xs); *)
normal lab t (NodeSet.get pl) xs
normal facto lab t (NodeSet.get pl) xs
(*
......@@ -1200,15 +1200,21 @@ struct
let aux_final res = IdMap.map_to_list conv_source_basic res in
return disp selected aux_final
let assoc v l =
try IdMap.assoc v l with Not_found -> -1
let assoc v (vars,nils,l) =
try IdMap.assoc v l with Not_found ->
if IdSet.mem vars v then -1
else if IdSet.mem nils v then -2
else assert false
let conv_source_prod left right v s = match s with
| Normal.SCatch -> Catch
| Normal.SConst c -> Const c
| Normal.SLeft -> Left (assoc v left)
| Normal.SRight -> Right (assoc v right)
| Normal.SRecompose -> Recompose (assoc v left, assoc v right)
| Normal.SRecompose ->
(match (assoc v left, assoc v right) with
| (-1,-1) -> Catch
| (l,r) -> Recompose (l,r))
module TypeList = SortedList.Make(Types)
let dispatch_basic disp : (Types.t * result) list =
......@@ -1244,13 +1250,13 @@ struct
if lab == LabelPool.dummy_max then None else Some lab
let get_tests pl f t d post =
let get_tests facto pl f t d post =
let pl = Array.map (List.map f) pl in
let lab = first_lab pl in
let pl = Array.map (List.map (fun (x,info) -> (Normal.nnf lab t x,info))) pl
let pl = Array.map (List.map (fun (x,info) -> Normal.nnf facto lab t x,info)) pl
in
(* Collect all subrequests *)
let aux reqs (req,_) = NfSet.add req reqs in
let aux reqs ((_,_,req),_) = NfSet.add req reqs in
let reqs = Array.fold_left (List.fold_left aux) NfSet.empty pl in
let reqs = Array.of_list (NfSet.elements reqs) in
(* Map subrequest -> idx in reqs *)
......@@ -1263,8 +1269,8 @@ struct
(* Build continuation *)
let result (t,_,m) =
let get a (req,info) =
match m.(NfMap.find req idx) with Some res -> (res,info)::a | _ -> a in
let get a ((vars,nils,req),info) =
match m.(NfMap.find req idx) with Some res -> ((vars,nils,res),info)::a | _ -> a in
let pl = Array.map (List.fold_left get []) pl in
d t pl
in
......@@ -1282,13 +1288,13 @@ struct
[(nnf, (xs, e))] in
let res _ pl =
let aux r = function
| [(res, (xs,e))] -> assert (r == Fail);
| [(([],[],res), (xs,e))] -> assert (r == Fail);
let m = List.map (fun x -> (x,IdMap.assoc x res)) xs in
Match (m,e)
| [] -> r | _ -> assert false in
Array.fold_left aux Fail pl in
let pl = Array.map aux (Array.of_list brs) in
get_tests pl (fun x -> x) t res (fun x -> x)
get_tests false pl (fun x -> x) t res (fun x -> x)
let rec dispatch_prod ?(kind=`Normal) disp =
......@@ -1298,13 +1304,13 @@ struct
let t = Types.Product.get ~kind disp.t in
dispatch_prod0 disp t (Array.map extr disp.pl)
and dispatch_prod0 disp t pl =
get_tests pl
get_tests true pl
(fun (res,p,q) -> p, (res,q))
(Types.Product.pi1 t)
(dispatch_prod1 disp t)
(fun x -> detect_left_tail_call (combine equal_result_dispatch x))
and dispatch_prod1 disp t t1 pl =
get_tests pl
get_tests true pl
(fun (ret1, (res,q)) -> q, (ret1,res) )
(Types.Product.pi2_restricted t1 t)
(dispatch_prod2 disp)
......@@ -1376,6 +1382,7 @@ struct
let rec print_source ppf = function
| Catch -> Format.fprintf ppf "v"
| Const c -> Types.Print.print_const ppf c
| Left (-2) | Right (-2) -> Format.fprintf ppf "`nil"
| Left (-1) -> Format.fprintf ppf "v1"
| Right (-1) -> Format.fprintf ppf "v2"
| Left i -> Format.fprintf ppf "l%i" i
......@@ -1418,17 +1425,17 @@ struct
let print_prod2 = function
| Impossible -> assert false
| Ignore r ->
Format.fprintf ppf " %a\n"
Format.fprintf ppf "%a\n"
print_ret r
| TailCall d ->
queue d;
Format.fprintf ppf " disp_%i v2@\n" d.id
Format.fprintf ppf "disp_%i v2@\n" d.id
| Dispatch (d, branches) ->
queue d;
Format.fprintf ppf " match v2 with disp_%i@\n" d.id;
Format.fprintf ppf "@\n match disp_%i v2 with@\n" d.id;
Array.iteri
(fun code r ->
Format.fprintf ppf " | %a -> %a\n"
Format.fprintf ppf " | %a -> %a@\n"
print_lhs (code, "r", d)
print_ret r;
)
......@@ -1437,19 +1444,18 @@ struct
let print_prod prefix ppf = function
| Impossible -> ()
| Ignore d2 ->
Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
Format.fprintf ppf " | %s(v1,v2) -> " prefix;
print_prod2 d2
| TailCall d ->
queue d;
Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
Format.fprintf ppf " disp_%i v1@\n" d.id
Format.fprintf ppf " | %s(v1,v2) -> disp_%i v1@\n" prefix d.id
| Dispatch (d,branches) ->
queue d;
Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
Format.fprintf ppf " match v1 with disp_%i@\n" d.id;
Format.fprintf ppf " match disp_%i v1 with@\n" d.id;
Array.iteri
(fun code d2 ->
Format.fprintf ppf " | %a -> @\n"
Format.fprintf ppf " | %a -> "
print_lhs (code, "l", d);
print_prod2 d2;
)
......@@ -1525,9 +1531,14 @@ struct
let lab = if lab == LabelPool.dummy_max then None else Some lab in
let pl = Array.of_list
(List.map (fun p -> Normal.nnf lab t ([p],t,fv p)) pl) in
(List.map (fun p ->
let n = Normal.nnf false lab t ([p],t,fv p) in
match n with
| [],[],x -> x
| _ -> assert false
) pl) in
show ppf t pl lab;
Format.fprintf ppf "# compiled dispatchers: %i@\n" !cur_id
(* Format.fprintf ppf "# compiled dispatchers: %i@\n" !cur_id *)
end
......
web/demo.js
View file @ 452a2518
......@@ -7,23 +7,12 @@ function show_result(pr,res)
function clearres(pr)
{ show_result(pr,""); }
function set_height(pr) {
var ct = document.getElementById(pr+"container");
var req = document.getElementById(pr+"req");
var edit = document.getElementById(pr+"edit");
if (req.style.visibility=='visible')
ct.style.height = req.offsetHeight + "px";
else
ct.style.height = edit.offsetHeight + "px";
}
function defreq(pr)
{ var req = document.getElementById(pr+"req");
var edit = document.getElementById(pr+"edit");
var def = document.getElementById(pr+"def");
edit.value = def.value;
req.innerHTML = HTMLEncode(def.value);
set_height(pr);
}
function submit(pr) {
......@@ -39,8 +28,7 @@ function submit(pr) {
function compute_prefix(pr) {
var prefix = document.getElementById(pr+"prefix").value;
if (prefix == "") return "";
var r = compute_prefix(prefix) + document.getElementById(prefix+"def").value;
// alert("pr="+pr+" prefix="+prefix+" r="+r);
var r = compute_prefix(prefix) + document.getElementById(prefix+"edit").value;
return(r + "\n");
}
......@@ -50,20 +38,19 @@ function editable(pr,b) {
var edit = document.getElementById(pr+"edit");
var btn = document.getElementById(pr+"btn");
var btnclear = document.getElementById(pr+"btnclear");
if ((req.style.visibility=='hidden') || (b == "init")) {
if ((req.style.display=='none') || (b == "init")) {
req.innerHTML = HTMLEncode(edit.value);
req.style.visibility='visible';
edit.style.visibility='hidden';
req.style.display='block';
edit.style.display='none';
btnclear.style.visibility='hidden';
btn.value="Edit";
}
else {
req.style.visibility='hidden';
edit.style.visibility='visible';
req.style.display='none';
edit.style.display='block';
btnclear.style.visibility='visible';
btn.value="Unedit";
}
set_height(pr);
}
function HTMLEncode(t) {
var t = t.toString();
......
web/demo.xml
View file @ 452a2518
......@@ -3,7 +3,19 @@
<!ENTITY leq "&#x2264;"> <!-- LESS_THAN OR EQUAL TO -->
]>
<page name="demo">
<title>CDuce demo</title>
<title>CDuce demo at PLANX 2005</title>
<box title="Introduction" link="intro">
<p>
This page is the support for the CDuce demo at the PLANX 2005 workshop
(Longbeach). The demo illustrates the use of first-class functions
in XML transformations. Here, functions are stored within documents.
</p>
<boxes-toc/>
</box>
<box title="Types, pattern matching" link="typpm">
<demo><![CDATA[
......@@ -13,8 +25,11 @@ type Title = <title>[ PCDATA ]
type Subtitle = <subtitle>[ PCDATA ]
type Author = <author>[ PCDATA ]
let title(Book -> String) <book>[ <title>x _* ] -> x
let authors(Book -> [Author+]) <_>[ (x::Author|_)* ] -> x
let title(Book -> String)
<book>[ <title>x _* ] -> x
let authors(Book -> [Author+])
<book>[ (x::Author|_)* ] -> x
]]></demo></box>
<box title="Sample values" link="samp"><demo prefix="last"><![CDATA[
......@@ -36,8 +51,11 @@ type ABook = <book print=FBook>[ Title Subtitle? Author+ ]
type ABib = [ ABook* ]
(* Remark: ABook <= Book, ABib <= Bib *)
let set(<book>c : Book)(f : FBook) : ABook = <book print=f>c
let prepare(b : Bib) : ABib = map b with x -> set x title
let set(<book>c : Book)(f : FBook) : ABook =
<book print=f>c
let prepare(b : Bib) : ABib =
map b with x -> set x title
let abib = prepare bib
]]></demo></box>
......@@ -55,7 +73,9 @@ let d = display abib
]]></demo></box>
<box title="Changing the style" link="style"><demo prefix="last"><![CDATA[
let change(p : Book -> Bool)(f : FBook)(b : ABib) : ABib =
let change(p : Book -> Bool)
(f : FBook)
(b : ABib) : ABib =
map b with x -> if (p x) then set x f else x
type HasSub = <_>[ _* Subtitle _* ]
......@@ -68,8 +88,18 @@ change
(fun (Book -> Bool) HasSub -> `true | _ -> `false)
(fun (b : Book) : String =
title b @ ": " @ subtitle (b :? HasSub))
let subtitle_first(Bib -> Bib; ABib -> ABib)
[ (x::HasSub|y::_)* ] -> x @ y
]]></demo></box>
<box title="Compilation of pattern-matching" link="pm"><demo prefix="last"><![CDATA[
debug compile
(*typ*) [ Title Subtitle? Author+ ]
(*pat*) [ (x::Author|_)* ]
]]></demo></box>
<!--
<box title="XML elements" link="xml">
<p>XML elements.</p>
......
web/site.cd
View file @ 452a2518
......@@ -278,9 +278,9 @@ let demo(no : Int)(name : String)(prefix : String)(txt : String) : H:Flow =
] ]
<tr>[
<td valign="top">[
<div style="position:relative;" id=(n@"container")>[
<pre style="z-level:1;" id=(n@"req")>txt
<textarea id=(n@"edit") cols="60" rows="25" style="position:absolute; top:0px; visibility: hidden; display:block;border:1px solid #CCCCCC; z-level:2; background-color:#EDEDED;">txt
<div id=(n@"container")>[
<pre id=(n@"req")>txt
<textarea id=(n@"edit") cols="50" rows="25" style="display:none;border:1px solid #CCCCCC; background-color:#F0F0F0;">txt
]
]
<td valign="top">[ <div id=(n@"res")>[] ] ] ]
......
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