Skip to content

GitLab

Commit 286b3b8b authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-12-05 15:47:05 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-12-05 15:48:13+00:00
parent 535f1839
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 791 additions and 248 deletions
Makefile
View file @ 286b3b8b
......@@ -102,6 +102,7 @@ clean:
rm -f cduce cduce.opt ocamlprof.dump
rm -f dtd2cduce pool webiface
rm -Rf prepro
rm -f web/index.html
.SUFFIXES: .ml .mli .cmo .cmi .cmx
......@@ -145,6 +146,8 @@ include depend
driver/examples.ml: cduce tests/web.cd tests/examples.xml
./cduce -quiet tests/web.cd
web/index.html: cduce
(cd web; ../cduce -quiet macros.cd)
# Site-specific installation
build_web:
......@@ -153,3 +156,7 @@ install_web:
ssh cduce@iris "cp ~frisch/IMPLEM/CDUCE/webiface cgi-bin/cduce2; cp ~frisch/IMPLEM/CDUCE/memento.html public_html/; chmod +s cgi-bin/cduce2"
install_web_local:
ssh root@localhost "cp ~beppe/IMPLEM/CDUCE/webiface /var/www/cgi-bin/cduce; cp ~beppe/IMPLEM/CDUCE/memento.html /var/www/html/; chmod +s /var/www/cgi-bin/cduce"
build_website:
rsh cedre ". .env; cd IMPLEM/CDUCE; make web/index.html"
scp web/index.html cduce@iris:public_html/
runtime/load_xml.ml
View file @ 286b3b8b
......@@ -36,10 +36,12 @@ let run s =
| Some x -> curr := x
| None -> () in
let txt = Buffer.create 1024 in
let rec parse_elt name att =
let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
let att = SortedMap.from_list (fun _ _ -> assert false) att in
let child = parse_seq true in
let child = parse_seq () in
let elt = Xml
(Atom (Types.AtomPool.mk name),
......@@ -50,21 +52,27 @@ let run s =
| _ -> failwith "Expect end_tag");
elt
and dump_txt q =
let data = Buffer.contents txt in
Buffer.clear txt;
if (is_ws data) then q () else string data (q ())
and parse_seq dropws =
and parse_seq () =
match !curr with
| E_start_tag (name,att,_) ->
| E_start_tag (name,att,_) ->
get ();
let e1 = parse_elt name att in
let rest = parse_seq true in
Pair (e1, rest)
dump_txt (fun () ->
let e1 = parse_elt name att in
let rest = parse_seq () in
Pair (e1, rest)
)
| E_char_data data ->
get ();
if dropws && (is_ws data)
then parse_seq true
else string data (parse_seq false)
get();
Buffer.add_string txt data;
parse_seq ()
| E_end_tag (_,_) ->
nil
dump_txt (fun () -> nil)
| _ -> failwith "Expect start_tag, char_data, or end_tag"
and parse_doc () =
......
runtime/print_xml.ml
View file @ 286b3b8b
......@@ -30,6 +30,8 @@ let string_of_xml v=
and write_att (n,v) = wms (" " ^ n ^ "=\""); wds v; wms "\"" in
let element_start name attrs =
wms ("<" ^ name); List.iter write_att attrs; wms "\n>"
and empty_element name attrs =
wms ("<" ^ name); List.iter write_att attrs; wms "/>"
and element_end name = wms ("</" ^ name ^ "\n>")
and document_start () =
(* wms ("<?xml version='1.0' encoding='" ^
......@@ -41,12 +43,15 @@ let string_of_xml v=
let rec print_elt = function
| Xml (Atom tag, Pair (Record attrs, content)) ->
let tag = Types.AtomPool.value tag in
element_start tag
(List.map (fun (n,v) ->
let attrs = List.map (fun (n,v) ->
if not (is_str v) then raise exn_print_xml;
(Types.LabelPool.value n,get_string v)) attrs);
print_content content;
element_end tag
(Types.LabelPool.value n,get_string v)) attrs in
(match content with
| Atom a when a = Sequence.nil_atom -> empty_element tag attrs
| _ ->
element_start tag attrs;
print_content content;
element_end tag)
| Char x ->
wds (String.make 1 (Chars.Unichar.to_char x)); (* TODO: opt *)
| _ -> raise exn_print_xml
......
runtime/run_dispatch.ml
View file @ 286b3b8b
......@@ -3,16 +3,16 @@
(* TODO: remove `Absent and clean .... *)
open Value
open Patterns.Compile
let make_result_prod v1 r1 v2 r2 v (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Left i -> if (i < 0) then v1 else r1.(i)
| `Right j -> if (j < 0) then v2 else r2.(j)
| `Recompose (i,j) ->
| Catch -> v
| Const c -> const c
| Left i -> if (i < 0) then v1 else r1.(i)
| Right j -> if (j < 0) then v2 else r2.(j)
| Recompose (i,j) ->
Pair ((if (i < 0) then v1 else r1.(i)),
(if (j < 0) then v2 else r2.(j)))
| _ -> assert false
......@@ -22,9 +22,9 @@ let make_result_prod v1 r1 v2 r2 v (code,r) =
let make_result_record fields v bindings (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Field (l,i) ->
| Catch -> v
| Const c -> const c
| Field (l,i) ->
if (i < 0) then List.assoc l fields
else (List.assoc l bindings).(i)
| _ -> assert false
......@@ -34,8 +34,8 @@ let make_result_record fields v bindings (code,r) =
let make_result_basic v (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| Catch -> v
| Const c -> const c
| _ -> assert false
) r in
(code,ret)
......@@ -43,28 +43,24 @@ let make_result_basic v (code,r) =
let dummy_r = [||]
let rec run_dispatcher d v =
let actions = Patterns.Compile.actions d in
match actions with
| `Ignore r -> make_result_basic v r
| `Kind k -> run_disp_kind k v
match actions d with
| AIgnore r -> make_result_basic v r
| AKind k -> run_disp_kind k 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 false actions.Patterns.Compile.record
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
| Record r -> run_disp_record r v [] r false actions.record
| Atom a ->
run_disp_basic v (fun t -> Types.Atom.has_atom t a)
actions.Patterns.Compile.basic
run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic
| Char c ->
run_disp_basic v (fun t -> Types.Char.has_char t c)
actions.Patterns.Compile.basic
run_disp_basic v (fun t -> Types.Char.has_char t c) actions.basic
| Integer i ->
run_disp_basic v (fun t -> Types.Int.has_int t i)
actions.Patterns.Compile.basic
run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
| Abstraction (iface,_) ->
run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
actions.Patterns.Compile.basic
actions.basic
| v ->
run_disp_kind actions (normalize v)
......@@ -78,19 +74,19 @@ and run_disp_basic v f x =
and run_disp_prod v v1 v2 x =
match x with
| `None -> assert false
| `TailCall d1 -> run_dispatcher d1 v1
| `Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
| `Dispatch (d1,b1) ->
| Impossible -> assert false
| TailCall d1 -> run_dispatcher d1 v1
| Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
| Dispatch (d1,b1) ->
let (code1,r1) = run_dispatcher d1 v1 in
run_disp_prod2 v1 r1 v v2 b1.(code1)
and run_disp_prod2 v1 r1 v v2 x =
match x with
| `None -> assert false
| `Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
| `TailCall d2 -> run_dispatcher d2 v2
| `Dispatch (d2,b2) ->
| Impossible -> assert false
| Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
| TailCall d2 -> run_dispatcher d2 v2
| Dispatch (d2,b2) ->
let (code2,r2) = run_dispatcher d2 v2 in
make_result_prod v1 r1 v2 r2 v b2.(code2)
......@@ -114,9 +110,9 @@ and run_disp_record' f v bindings fields other = function
aux other fields
and run_disp_field f v bindings fields other l vl = function
| `None -> assert false
| `Ignore r -> run_disp_record' f v bindings fields other r
| `TailCall d -> run_dispatcher d vl
| `Dispatch (dl,bl) ->
| Impossible -> assert false
| Ignore r -> run_disp_record' f v bindings fields other r
| TailCall d -> run_dispatcher d vl
| Dispatch (dl,bl) ->
let (codel,rl) = run_dispatcher dl vl in
run_disp_record' f v ((l,rl)::bindings) fields other bl.(codel)
tests/memento.cd
View file @ 286b3b8b
......@@ -74,7 +74,7 @@ let fun summary (Content' -> [Block*])
c ->
let s = transform c with <section no=i>[<title>t; _] ->
[<li>[<a href="#" @ string_of i>t]] in
match s with lis -> box [<ul>lis];;
match s with [] -> [] | lis -> box [<ul>lis];;
let (fname, title, content) =
......
tests/overloading.cd
View file @ 286b3b8b
......@@ -73,3 +73,5 @@ name (sort base);;
transform [ base base ] with
<person>[ n <children>[Person]; _] -> [n]
| _ -> [];;
debug compile Any Any;;
types/patterns.ml
View file @ 286b3b8b
This diff is collapsed.
types/patterns.mli
View file @ 286b3b8b
......@@ -49,8 +49,8 @@ module Compile: sig
type dispatcher
type actions =
[ `Ignore of result
| `Kind of actions_kind ]
| AIgnore of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.descr * result) list;
prod: result dispatch dispatch;
......@@ -63,17 +63,16 @@ module Compile: sig
| `Result_other of Types.label list * result * result ]
and 'a dispatch =
[ `Dispatch of dispatcher * 'a array
| `TailCall of dispatcher
| `Ignore of 'a
| `None ]
| Dispatch of dispatcher * 'a array
| TailCall of dispatcher
| Ignore of 'a
| Impossible
and result = int * source array
and source =
[ `Catch | `Const of Types.const
| `Left of int | `Right of int | `Recompose of int * int
| `Field of Types.label * int
]
| Catch | Const of Types.const
| Left of int | Right of int | Recompose of int * int
| Field of Types.label * int
val actions: dispatcher -> actions
......
typing/typer.ml
View file @ 286b3b8b
......@@ -30,18 +30,17 @@ type ti = {
mutable pat_node: Patterns.node option
}
and descr =
[ `Alias of string * ti
| `Type of Types.descr
| `Or of ti * ti
| `And of ti * ti
| `Diff of ti * ti
| `Times of ti * ti
| `Xml of ti * ti
| `Arrow of ti * ti
| `Record of bool * (Types.label * bool * ti) list
| `Capture of Patterns.capture
| `Constant of Patterns.capture * Types.const
]
| IAlias of string * ti
| IType of Types.descr
| IOr of ti * ti
| IAnd of ti * ti
| IDiff of ti * ti
| ITimes of ti * ti
| IXml of ti * ti
| IArrow of ti * ti
| IRecord of bool * (Types.label * bool * ti) list
| ICapture of Patterns.capture
| IConstant of Patterns.capture * Types.const
type glb = ti StringMap.t
......@@ -55,7 +54,7 @@ let mk' =
seen = false;
loc' = loc;
fv = None;
descr' = `Alias ("__dummy__", x);
descr' = IAlias ("__dummy__", x);
type_node = None;
pat_node = None
} in
......@@ -91,32 +90,33 @@ module Regexp = struct
let uniq_id = let r = ref 0 in fun () -> incr r; !r
type flat = [ `Epsilon
| `Elem of int * Ast.ppat (* the int arg is used
type flat =
| REpsilon
| RElem of int * Ast.ppat (* the int arg is used
to stop generic comparison *)
| `Seq of flat * flat
| `Alt of flat * flat
| `Star of flat
| `WeakStar of flat ]
| RSeq of flat * flat
| RAlt of flat * flat
| RStar of flat
| RWeakStar of flat
let re_loc = ref noloc
let rec propagate vars : regexp -> flat = function
| Epsilon -> `Epsilon
| Elem x -> let p = vars x in `Elem (uniq_id (),p)
| Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)
| Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)
| Star r -> `Star (propagate vars r)
| WeakStar r -> `WeakStar (propagate vars r)
| Epsilon -> REpsilon
| Elem x -> let p = vars x in RElem (uniq_id (),p)
| Seq (r1,r2) -> RSeq (propagate vars r1,propagate vars r2)
| Alt (r1,r2) -> RAlt (propagate vars r1, propagate vars r2)
| Star r -> RStar (propagate vars r)
| WeakStar r -> RWeakStar (propagate vars r)
| SeqCapture (v,x) ->
let v= mk !re_loc (Capture v) in
propagate (fun p -> mk !re_loc (And (vars p,v))) x
let cup r1 r2 =
match (r1,r2) with
| (_, `Empty) -> r1
| (`Empty, _) -> r2
| (`Res t1, `Res t2) -> `Res (mk !re_loc (Or (t1,t2)))
let dummy_pat = mk noloc (PatVar "DUMMY")
let cup r1 r2 =
if r1 == dummy_pat then r2 else
if r2 == dummy_pat then r1 else
mk !re_loc (Or (r1,r2))
(*TODO: review this compilation schema to avoid explosion when
coding (Optional x) by (Or(Epsilon,x)); memoization ... *)
......@@ -126,24 +126,24 @@ module Regexp = struct
let memo = ref Memo.empty
let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =
if Coind.mem seq !e then `Empty
let rec compile fin e seq : Ast.ppat =
if Coind.mem seq !e then dummy_pat
else (
e := Coind.add seq !e;
match seq with
| [] ->
`Res fin
| `Epsilon :: rest ->
fin
| REpsilon :: rest ->
compile fin e rest
| `Elem (_,p) :: rest ->
`Res (mk !re_loc (Prod (p, guard_compile fin rest)))
| `Seq (r1,r2) :: rest ->
| RElem (_,p) :: rest ->
mk !re_loc (Prod (p, guard_compile fin rest))
| RSeq (r1,r2) :: rest ->
compile fin e (r1 :: r2 :: rest)
| `Alt (r1,r2) :: rest ->
| RAlt (r1,r2) :: rest ->
cup (compile fin e (r1::rest)) (compile fin e (r2::rest))
| `Star r :: rest ->
| RStar r :: rest ->
cup (compile fin e (r::seq)) (compile fin e rest)
| `WeakStar r :: rest ->
| RWeakStar r :: rest ->
cup (compile fin e rest) (compile fin e (r::seq))
)
and guard_compile fin seq =
......@@ -154,9 +154,8 @@ module Regexp = struct
let v = mk !re_loc (PatVar n) in
memo := Memo.add seq v !memo;
let d = compile fin (ref Coind.empty) seq in
(match d with
| `Empty -> assert false
| `Res d -> defs := (n,d) :: !defs);
assert (d != dummy_pat);
defs := (n,d) :: !defs;
v
(*
......@@ -254,23 +253,23 @@ let rec compile env { loc = loc; descr = d } : ti =
)
| Recurs (t, b) -> compile (compile_many env b) t
| 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) -> 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))
| Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
| Internal t -> cons loc (IType t)
| Or (t1,t2) -> cons loc (IOr (compile env t1, compile env t2))
| And (t1,t2) -> cons loc (IAnd (compile env t1, compile env t2))
| Diff (t1,t2) -> cons loc (IDiff (compile env t1, compile env t2))
| Prod (t1,t2) -> cons loc (ITimes (compile env t1, compile env t2))
| XmlT (t1,t2) -> cons loc (IXml (compile env t1, compile env t2))
| Arrow (t1,t2) -> cons loc (IArrow (compile env t1, compile env t2))
| Record (o,r) ->
cons loc (`Record (o, List.map (fun (l,o,t) -> l,o,compile env t) r))
| Constant (x,v) -> cons loc (`Constant (x,v))
| Capture x -> cons loc (`Capture x)
cons loc (IRecord (o, List.map (fun (l,o,t) -> l,o,compile env t) r))
| Constant (x,v) -> cons loc (IConstant (x,v))
| Capture x -> cons loc (ICapture x)
and compile_many env b =
let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in
let env =
List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
List.iter (fun (v,t,x) -> x.descr' <- IAlias (v, compile env t)) b;
env
module IntSet =
......@@ -283,23 +282,23 @@ let rec comp_fv s =
| Some fv -> comp_fv_res := StringSet.union fv !comp_fv_res
| None ->
(match s.descr' with
| `Alias (_,x) ->
| IAlias (_,x) ->
if x.seen then ()
else (
x.seen <- true;
comp_fv_seen := x :: !comp_fv_seen;
comp_fv x
)
| `Or (s1,s2)
| `And (s1,s2)
| `Diff (s1,s2)
| `Times (s1,s2) | `Xml (s1,s2)
| `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
| `Record (_,r) -> List.iter (fun (l,opt,s) -> comp_fv s) r
| `Type _ -> ()
| `Capture x
| `Constant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res
)
| IOr (s1,s2)
| IAnd (s1,s2)
| IDiff (s1,s2)
| ITimes (s1,s2) | IXml (s1,s2)
| IArrow (s1,s2) -> comp_fv s1; comp_fv s2
| IRecord (_,r) -> List.iter (fun (l,opt,s) -> comp_fv s) r
| IType _ -> ()
| ICapture x
| IConstant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res
)
let fv s =
......@@ -316,22 +315,22 @@ let fv s =
let rec typ seen s : Types.descr =
match s.descr' with
| `Alias (v,x) ->
| IAlias (v,x) ->
if IntSet.mem s.id seen then
raise_loc_generic s.loc'
("Unguarded recursion on variable " ^ v ^ " in this type")
else typ (IntSet.add s.id 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)
| `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 (o,r) ->
| IType t -> t
| IOr (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
| IAnd (s1,s2) -> Types.cap (typ seen s1) (typ seen s2)
| IDiff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
| ITimes (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
| IXml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2)
| IArrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
| IRecord (o,r) ->
Types.record'
(o,List.map (fun (l,o,s) -> (l,(o,typ_node s))) r)
| `Capture x | `Constant (x,_) -> assert false
| ICapture x | IConstant (x,_) -> assert false
and typ_node s : Types.node =
match s.type_node with
......@@ -359,22 +358,22 @@ let rec pat seen s : Patterns.descr =
and pat_aux seen s = match s.descr' with
| `Alias (v,x) ->
| IAlias (v,x) ->
if IntSet.mem s.id seen
then raise
(Patterns.Error
("Unguarded recursion on variable " ^ v ^ " in this pattern"));
pat (IntSet.add s.id seen) x
| `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
| `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
| `Diff (s1,s2) when StringSet.is_empty (fv s2) ->
| IOr (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
| IAnd (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
| IDiff (s1,s2) when StringSet.is_empty (fv s2) ->
let s2 = Types.neg (Types.descr (type_node s2)) in
Patterns.cap (pat seen s1) (Patterns.constr s2)
| `Diff _ ->
| IDiff _ ->
raise (Patterns.Error "Difference not allowed in patterns")
| `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
| `Xml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
| `Record (o,r) ->
| ITimes (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
| IXml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
| IRecord (o,r) ->
let pats = ref [] in
let aux (l,o,s) =
if StringSet.is_empty (fv s) then (l,(o,type_node s))
......@@ -390,11 +389,11 @@ and pat_aux seen s = match s.descr' with
let constr = Types.record' (o,List.map aux r) in
List.fold_left Patterns.cap (Patterns.constr constr) !pats
(* TODO: can avoid constr when o=true, and all fields have fv *)
| `Capture x -> Patterns.capture x
| `Constant (x,c) -> Patterns.constant x c
| `Arrow _ ->
| ICapture x -> Patterns.capture x
| IConstant (x,c) -> Patterns.constant x c
| IArrow _ ->
raise (Patterns.Error "Arrow not allowed in patterns")
| `Type _ -> assert false
| IType _ -> assert false
and pat_node s : Patterns.node =
match s.pat_node with
......
web/index.xml 0 → 100644
View file @ 286b3b8b
<?xml version="1.0" standalone="yes" encoding="iso8859-1"?>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"/>
<title>CDuce</title>
</head>
<body bgcolor="#BBDDFF">
<banner title="CDuce" subtitle="Page last modified on 2002-12-05"/>
<p/>