Skip to content

GitLab

C
cduce
Commit c66d89b5 authored by Pietro Abate's avatar Pietro Abate
Browse files
Options

[r2003-03-08 15:10:01 by cvscast] Empty log message 

Original author: cvscast
Date: 2003-03-08 15:10:03+00:00
parent 2a116016
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 486 additions and 994 deletions
Makefile
View file @ c66d89b5
......@@ -15,6 +15,7 @@ TYPING = typing/typed.cmo typing/typer.cmo
TYPES = \
types/sortedList.cmo types/sortedMap.cmo types/boolean.cmo \
types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo \
types/normal.cmo \
types/types.cmo \
......
depend
View file @ c66d89b5
......@@ -4,28 +4,28 @@ misc/pool.cmo: misc/state.cmi misc/pool.cmi
misc/pool.cmx: misc/state.cmx misc/pool.cmi
misc/state.cmo: misc/state.cmi
misc/state.cmx: misc/state.cmi
parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
parser/ast.cmo: types/ident.cmo parser/location.cmi types/types.cmi
parser/ast.cmx: types/ident.cmx parser/location.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
types/intervals.cmi parser/location.cmi types/sequence.cmi \
types/types.cmi parser/wlexer.cmo parser/parser.cmi
types/ident.cmo types/intervals.cmi parser/location.cmi \
types/sequence.cmi types/types.cmi parser/wlexer.cmo parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/intervals.cmx parser/location.cmx types/sequence.cmx \
types/types.cmx parser/wlexer.cmx parser/parser.cmi
types/ident.cmx types/intervals.cmx parser/location.cmx \
types/sequence.cmx types/types.cmx parser/wlexer.cmx parser/parser.cmi
parser/wlexer.cmo: parser/location.cmi
parser/wlexer.cmx: parser/location.cmx
typing/typed.cmo: parser/location.cmi types/patterns.cmi types/sortedMap.cmi \
types/types.cmi
typing/typed.cmx: parser/location.cmx types/patterns.cmx types/sortedMap.cmx \
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/intervals.cmi \
parser/location.cmi types/patterns.cmi types/sequence.cmi \
types/sortedList.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/intervals.cmx \
parser/location.cmx types/patterns.cmx types/sequence.cmx \
types/sortedList.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
types/sortedMap.cmi types/types.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
types/sortedMap.cmx types/types.cmx
typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/ident.cmo \
types/intervals.cmi parser/location.cmi types/patterns.cmi \
types/sequence.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx types/patterns.cmx \
types/sequence.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
types/atoms.cmo: misc/pool.cmi types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: misc/pool.cmx types/sortedList.cmx types/atoms.cmi
types/boolean.cmo: types/sortedList.cmi types/boolean.cmi
......@@ -36,14 +36,16 @@ types/builtin.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
types/types.cmx
types/chars.cmo: types/chars.cmi
types/chars.cmx: types/chars.cmi
types/ident.cmo: misc/pool.cmi types/sortedList.cmi
types/ident.cmx: misc/pool.cmx types/sortedList.cmx
types/intervals.cmo: types/intervals.cmi
types/intervals.cmx: types/intervals.cmi
types/normal.cmo: types/normal.cmi
types/normal.cmx: types/normal.cmi
types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi misc/state.cmi \
types/types.cmi types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx misc/state.cmx \
types/types.cmx types/patterns.cmi
types/patterns.cmo: types/ident.cmo types/sortedList.cmi types/sortedMap.cmi \
misc/state.cmi types/types.cmi types/patterns.cmi
types/patterns.cmx: types/ident.cmx types/sortedList.cmx types/sortedMap.cmx \
misc/state.cmx types/types.cmx types/patterns.cmi
types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi
types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx
types/recursive_share.cmo: types/recursive.cmo misc/state.cmi
......@@ -56,20 +58,20 @@ types/sortedMap.cmo: types/sortedMap.cmi
types/sortedMap.cmx: types/sortedMap.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/bdd.cmo types/boolean.cmi \
types/chars.cmi types/intervals.cmi types/normal.cmi misc/pool.cmi \
types/recursive.cmo types/sortedList.cmi types/sortedMap.cmi \
misc/state.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/bdd.cmx types/boolean.cmx \
types/chars.cmx types/intervals.cmx types/normal.cmx misc/pool.cmx \
types/recursive.cmx types/sortedList.cmx types/sortedMap.cmx \
misc/state.cmx types/types.cmi
runtime/eval.cmo: types/atoms.cmi types/intervals.cmi runtime/load_xml.cmi \
parser/location.cmi runtime/print_xml.cmo runtime/run_dispatch.cmi \
misc/state.cmi typing/typed.cmo runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: types/atoms.cmx types/intervals.cmx runtime/load_xml.cmx \
parser/location.cmx runtime/print_xml.cmx runtime/run_dispatch.cmx \
misc/state.cmx typing/typed.cmx runtime/value.cmx runtime/eval.cmi
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi types/normal.cmi misc/pool.cmi types/recursive.cmo \
types/sortedList.cmi types/sortedMap.cmi misc/state.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx types/normal.cmx misc/pool.cmx types/recursive.cmx \
types/sortedList.cmx types/sortedMap.cmx misc/state.cmx types/types.cmi
runtime/eval.cmo: types/atoms.cmi types/ident.cmo types/intervals.cmi \
runtime/load_xml.cmi parser/location.cmi runtime/print_xml.cmo \
runtime/run_dispatch.cmi misc/state.cmi typing/typed.cmo \
runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: types/atoms.cmx types/ident.cmx types/intervals.cmx \
runtime/load_xml.cmx parser/location.cmx runtime/print_xml.cmx \
runtime/run_dispatch.cmx misc/state.cmx typing/typed.cmx \
runtime/value.cmx runtime/eval.cmi
runtime/load_xml.cmo: types/atoms.cmi parser/location.cmi types/sortedMap.cmi \
types/types.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: types/atoms.cmx parser/location.cmx types/sortedMap.cmx \
......@@ -87,13 +89,13 @@ runtime/value.cmo: types/atoms.cmi types/chars.cmi types/intervals.cmi \
runtime/value.cmx: types/atoms.cmx types/chars.cmx types/intervals.cmx \
types/sequence.cmx types/sortedMap.cmx types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
parser/location.cmi parser/parser.cmi types/patterns.cmi misc/state.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
parser/wlexer.cmo driver/cduce.cmi
types/ident.cmo parser/location.cmi parser/parser.cmi types/patterns.cmi \
misc/state.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx misc/state.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
parser/wlexer.cmx driver/cduce.cmi
types/ident.cmx parser/location.cmx parser/parser.cmx types/patterns.cmx \
misc/state.cmx typing/typed.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
driver/run.cmo: driver/cduce.cmi parser/location.cmi misc/state.cmi \
types/types.cmi
driver/run.cmx: driver/cduce.cmx parser/location.cmx misc/state.cmx \
......@@ -105,16 +107,17 @@ driver/webiface.cmx: driver/cduce.cmx driver/examples.cmx parser/location.cmx \
toplevel/toploop.cmo: parser/parser.cmi
toplevel/toploop.cmx: parser/parser.cmx
parser/parser.cmi: parser/ast.cmo
typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi
typing/typer.cmi: parser/ast.cmo types/ident.cmo typing/typed.cmo \
types/types.cmi
types/boolean.cmi: types/sortedList.cmi
types/normal.cmi: types/boolean.cmi
types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/patterns.cmi: types/ident.cmo types/types.cmi
types/sequence.cmi: types/atoms.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
misc/pool.cmi types/sortedMap.cmi
runtime/eval.cmi: typing/typed.cmo runtime/value.cmi
runtime/eval.cmi: types/ident.cmo typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
......
driver/cduce.ml
View file @ c66d89b5
open Location
open Ident
let quiet = ref false
let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
let glb_env = State.ref "Cduce.glb_env" Typer.Env.empty
let glb_env = State.ref "Cduce.glb_env" Typer.TypeEnv.empty
let eval_env = Eval.global_env
let print_norm ppf d =
......@@ -15,13 +16,13 @@ let print_value ppf v =
let dump_env ppf =
Format.fprintf ppf "Global types:";
Typer.Env.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;
Typer.TypeEnv.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;
Format.fprintf ppf ".@\n";
Eval.Env.iter
(fun x v ->
let t = Typer.Env.find x !typing_env in
Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"
x
(Id.value x)
print_norm t
print_value v
)
......@@ -95,7 +96,7 @@ let debug ppf = function
and p = Typer.pat !glb_env p in
let f = Patterns.filter (Types.descr t) p in
List.iter (fun (x,t) ->
Format.fprintf ppf " %s:%a@\n" x
Format.fprintf ppf " %s:%a@\n" (Id.value x)
print_norm (Types.descr t)) f
| `Compile2 (t,pl) ->
Format.fprintf ppf "[DEBUG:compile2]@\n";
......@@ -181,7 +182,7 @@ let run ppf ppf_err input =
List.iter (fun (x,t) ->
typing_env := Typer.Env.add x t !typing_env;
if not !quiet then
Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t)
in
let type_decl decl =
......@@ -194,7 +195,7 @@ let run ppf ppf_err input =
(fun (x,v) ->
Eval.enter_global x v;
if not !quiet then
Format.fprintf ppf "=> %s : @[%a@]@\n@." x print_value v
Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v
) bindings
in
......
misc/pool.ml
View file @ c66d89b5
......@@ -20,21 +20,23 @@ struct
type t = int
type value = H.t
let cache = State.ref "Pool.cache" (Hashtbl.create 63)
module Tbl = Hashtbl.Make(H)
let cache = State.ref "Pool.cache" (Tbl.create 63)
let values = State.ref "Pool.values" (Array.create 63 None)
let counter = State.ref "Pool.counter" 0
let clear () =
Hashtbl.clear !cache;
Tbl.clear !cache;
values := Array.create 63 None;
counter := 0
let mk x =
try Hashtbl.find !cache x
try Tbl.find !cache x
with Not_found ->
let n = !counter in
incr counter;
Hashtbl.add !cache x n;
Tbl.add !cache x n;
if (n = Array.length !values) then
(
let new_values = Array.create (2 * Array.length !values) None in
......
parser/ast.ml
View file @ c66d89b5
(* Abstract syntax as produced by the parsed *)
open Location
open Ident
type pprog = pmodule_item list
......@@ -26,7 +27,7 @@ and pexpr = pexpr' located
and pexpr' =
| Forget of pexpr * ppat
(* CDuce is a Lambda-calculus ... *)
| Var of string
| Var of id
| Apply of pexpr * pexpr
| Abstraction of abstr
......@@ -46,7 +47,7 @@ and pexpr' =
| Try of pexpr * branches
and abstr = {
fun_name : string option;
fun_name : id option;
fun_iface : (ppat * ppat) list;
fun_body : branches
}
......@@ -67,8 +68,8 @@ and ppat' =
| XmlT of ppat * ppat
| Arrow of ppat * ppat
| Record of bool * (Types.label * bool * ppat) list
| Capture of Patterns.capture
| Constant of Patterns.capture * Types.const
| Capture of id
| Constant of id * Types.const
| Regexp of regexp * ppat
and regexp =
......@@ -78,5 +79,5 @@ and regexp =
| Alt of regexp * regexp
| Star of regexp
| WeakStar of regexp
| SeqCapture of Patterns.capture * regexp
| SeqCapture of id * regexp
parser/parser.ml
View file @ c66d89b5
open Location
open Ast
open Ident
(*
let () = Grammar.error_verbose := true
......@@ -87,12 +88,12 @@ EXTEND
[ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
| "try"; e = SELF; "with"; b = branches ->
let default =
(mk noloc (Capture "x"),
mk noloc (Op ("raise",[mk noloc (Var "x")]))) in
(mk noloc (Capture (ident "x")),
mk noloc (Op ("raise",[mk noloc (Var (ident "x"))]))) in
mk loc (Try (e,b@[default]))
| "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
| "transform"; e = SELF; "with"; b = branches ->
let default = mk noloc (Capture "x"), cst_nil in
let default = mk noloc (Capture (ident "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 })
......@@ -113,10 +114,10 @@ EXTEND
let tag = mk loc (Internal (Types.atom (Atoms.any))) in
let att = mk loc (Internal Types.Record.any) in
let any = mk loc (Internal (Types.any)) in
let re = Star(Alt(SeqCapture("x",Elem p), Elem any)) in
let re = Star(Alt(SeqCapture(ident "x",Elem p), Elem any)) in
let ct = mk loc (Regexp (re,any)) in
let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
let b = (p, mk loc (Var "x")) in
let b = (p, mk loc (Var (ident "x"))) in
mk loc (Op ("flatten", [mk loc (Map (e,[b]))]))
]
|
......@@ -161,7 +162,7 @@ EXTEND
| "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
| s = STRING2 ->
tuple loc (char_list loc s @ [cst_nil])
| a = LIDENT -> mk loc (Var a)
| a = LIDENT -> mk loc (Var (ident a))
]
];
......@@ -190,7 +191,7 @@ EXTEND
fun_decl: [
(* need an hack to do this, because both productions would
match [ OPT LIDENT; "("; pat ] .... *)
[ f = OPT LIDENT; "("; p1 = pat LEVEL "no_arrow";
[ f = OPT [ x = LIDENT -> ident x]; "("; p1 = pat LEVEL "no_arrow";
res = [ "->"; p2 = pat;
a = [ ";"; a = LIST0 arrow SEP ";" -> a | -> [] ];
")"; b = branches -> `Classic (p2,a,b)
......@@ -228,7 +229,7 @@ EXTEND
regexp: [
[ x = regexp; "|"; y = regexp -> Alt (x,y) ]
| [ x = regexp; y = regexp -> Seq (x,y) ]
| [ a = LIDENT; "::"; x = regexp -> SeqCapture (a,x) ]
| [ a = LIDENT; "::"; x = regexp -> SeqCapture (ident a,x) ]
| [ x = regexp; "*" -> Star x
| x = regexp; "*?" -> WeakStar x
| x = regexp; "+" -> Seq (x, Star x)
......@@ -236,7 +237,8 @@ EXTEND
| x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "??" -> Alt (Epsilon, x) ]
| [ "("; x = regexp; ")" -> x
| "("; a = LIDENT; ":="; c = const; ")" -> Elem (mk loc (Constant (a,c)))
| "("; a = LIDENT; ":="; c = const; ")" ->
Elem (mk loc (Constant ((ident a,c))))
| UIDENT "PCDATA" -> string_regexp
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.mk_char (parse_char loc i)
......@@ -267,8 +269,9 @@ EXTEND
[ "{"; r = record_spec; "}" -> mk loc (Record (true,r))
| "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
| LIDENT "_" -> mk loc (Internal Types.any)
| a = LIDENT -> mk loc (Capture a)
| "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
| a = LIDENT -> mk loc (Capture (ident a))
| "("; a = LIDENT; ":="; c = const; ")" ->
mk loc (Constant (ident a,c))
| a = UIDENT -> mk loc (PatVar a)
| i = INT ; "--"; j = INT ->
let i = Intervals.mk i
......
runtime/eval.ml
View file @ c66d89b5
open Value
open Run_dispatch
open Ident
module Env = Map.Make (struct type t = string let compare = compare end)
module Env = Map.Make (Ident.Id)
type env = t Env.t
let global_env = State.ref "Eval.global_env" Env.empty
......@@ -27,7 +28,7 @@ let rec eval env e0 =
| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a ->
let env =
List.fold_left
IdSet.fold
(fun accu x ->
try Env.add x (Env.find x env) accu
with Not_found -> accu (* global *))
......@@ -86,15 +87,15 @@ and eval_branches env brs arg =
let (bind, e) = rhs.(code) in
let env =
List.fold_left (fun env (x,i) ->
if (i = -1) then Env.add x arg env
else Env.add x bindings.(i) env) env bind in
if (i = -1) then Env.add x arg env
else Env.add x bindings.(i) env) env (IdMap.get bind) in
eval env e
and eval_let_decl env l =
let v = eval env l.Typed.let_body in
let (disp,bind) = Typed.dispatcher_let_decl l in
let (_,bindings) = run_dispatcher disp v in
List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) bind
List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) (IdMap.get bind)
and eval_map env brs = function
| Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
......
runtime/eval.mli
View file @ c66d89b5
open Value
open Ident
module Env : Map.S with type key = string
module Env : Map.S with type key = id
type env = t Env.t
val global_env : env ref
val enter_global : string -> t -> unit
val enter_global : id -> t -> unit
val eval: env -> Typed.texpr -> t
val eval_let_decl: env -> Typed.let_decl -> (string * t) list
val eval_let_decl: env -> Typed.let_decl -> (id * t) list
tests/xhtml.cd
View file @ c66d89b5
......@@ -250,5 +250,7 @@ type X_head =
];;
type X_html = <html>[ (X_head X_body) ];;
match load_xml "tests/xhtml.xml" with X_html -> `Ok | _ -> `Not_ok;;
(*
match load_xml "tests/xhtml.xml" with x -> x;;
*)
types/atoms.ml
View file @ c66d89b5
module HashedString =
struct
type t = string
let hash = Hashtbl.hash
let equal = (=)
end
module AtomPool = Pool.Make(HashedString)
module AtomPool = Pool.Make(SortedList.String)
type v = AtomPool.t
let value = AtomPool.value
let mk = AtomPool.mk
module SList = SortedList.Make(
struct
type 'a t = v
let compare = AtomPool.compare
let hash = AtomPool.hash
let equal = AtomPool.equal
end)
module SList = SortedList.Make_transp(SortedList.Lift(AtomPool))
type t = Finite of unit SList.t | Cofinite of unit SList.t
let empty = Finite []
......
types/boolean.ml
View file @ c66d89b5
......@@ -17,7 +17,7 @@ sig
val atom : 'a elem -> 'a t
val map : ('a elem-> 'b elem) -> 'a t -> 'b t
val iter: ('a elem-> unit) -> 'a t -> unit
val iter: ('a elem -> unit) -> 'a t -> unit
val compute: empty:'d -> full:'c -> cup:('d -> 'c -> 'd)
-> cap:('c -> 'b -> 'c) -> diff:('c -> 'b -> 'c) ->
atom:('a elem -> 'b) -> 'a t -> 'd
......@@ -32,8 +32,8 @@ end
module Make(X : SortedList.ARG) = struct
type 'a elem = 'a X.t
module SList = SortedList.Make(X)
module SSList = SortedList.Make
module SList = SortedList.Make_transp(X)
module SSList = SortedList.Make_transp
(struct
type 'a t = 'a SList.t * 'a SList.t
let compare (x1,y1) (x2,y2) =
......@@ -53,24 +53,27 @@ module Make(X : SortedList.ARG) = struct
let empty = [ ]
let full = [ [],[] ]
let full = [ ([],[]) ]
let atom x = [ ([x],[]) ]
let atom x = [ [x],[] ]
let may_remove (p1,n1) (p2,n2) =
(SList.subset p2 p1) && (SList.subset n2 n1)
let cup t s =
if t == s then t
else if t = empty then s else if s = empty then t
else if (t = full) || (s = full) then full
else
let s=
List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) t)) s in
let t=
List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in
SSList.cup s t
else match (t,s) with
| [],s -> s
| t,[] -> t
| [ [], [] ], _ | _, [ [], [] ] -> full
| _ ->
let s=
SSList.filter
(fun (p,n) -> not (SSList.exists (may_remove (p,n)) t)) s in
let t=
SSList.filter
(fun (p,n) -> not (SSList.exists (may_remove (p,n)) s)) t in
SSList.cup s t
let tot = ref 0
let clean accu t =
......@@ -108,7 +111,7 @@ let cap s t =
then (SList.cup p1 p2, SList.cup n1 n2) :: lines
else lines
in
clean common (fold2 aux [] lines1 lines2)
clean (SSList.get common) (fold2 aux [] (SSList.get lines1) (SSList.get lines2))
let diff c1 c2 =
if c2 == full then empty
......@@ -116,11 +119,11 @@ let diff c1 c2 =
else
let c1 = SSList.diff c1 c2 in
let line (p,n) =
let acc = List.fold_left (fun acc a -> ([], [a]) :: acc) [] p in
let acc = List.fold_left (fun acc a -> ([a], []) :: acc) acc n in
let acc = SList.fold (fun acc a -> ([], [a]) :: acc) [] p in
let acc = SList.fold (fun acc a -> ([a], []) :: acc) acc n in
SSList.from_list acc
in
List.fold_left (fun c1 l -> cap c1 (line l)) c1 c2
SSList.fold (fun c1 l -> cap c1 (line l)) c1 c2
let rec map f t =
......@@ -135,7 +138,7 @@ let rec map f t =
SSList.from_list lines
let iter f t =
List.iter (fun (p,n) -> List.iter f p; List.iter f n) t
SSList.iter (fun (p,n) -> SList.iter f p; SList.iter f n) t
let compute ~empty ~full ~cup ~cap ~diff ~atom t =
let line (p,n) =
......@@ -170,15 +173,17 @@ let print any f =
)
)
let check b =
let check b = ()
(*
SSList.check b;
List.iter
SSList.iter
(fun (p,n) ->
SList.check p;
SList.check n;
assert (SList.disjoint p n)
)
b
*)
end
......
types/patterns.ml
View file @ c66d89b5
This diff is collapsed.
types/patterns.mli
View file @ c66d89b5
type capture = string
type fv = capture SortedList.t
exception Error of string
open Ident
(* Pattern algebra *)
......@@ -19,8 +17,8 @@ val times : node -> node -> descr
val xml : node -> node -> descr
val record : Types.label -> node -> descr
val capture : capture -> descr
val constant: capture -> Types.const -> descr
val capture : id -> descr
val constant: id -> Types.const -> descr
val id: node -> int
val descr: node -> descr
......@@ -29,7 +27,7 @@ val fv : node -> fv
(* Pattern matching: static semantics *)
val accept : node -> Types.node
val filter : Types.descr -> node -> (capture,Types.node) SortedMap.t
val filter : Types.descr -> node -> (id * Types.node) list
(*
......@@ -78,7 +76,7 @@ module Compile: sig
val make_branches :
Types.descr -> (node * 'a) list ->
dispatcher * ((capture, int) SortedMap.t * 'a) array
dispatcher * (int id_map * 'a) array
val debug_compile : Format.formatter -> Types.node -> node list -> unit
end
types/sortedList.ml
View file @ c66d89b5
......@@ -5,6 +5,22 @@ module type ARG = sig
val compare: 'a t -> 'a t -> int
end
module type ARG0 =
sig
type t
val equal: t -> t -> bool
val hash: t -> int
val compare: t -> t -> int
end
module Lift(X : ARG0) =
struct
type 'a t = X.t
let equal = X.equal
let hash = X.hash
let compare = X.compare
end
module type S =
sig
type 'a elem
......@@ -13,8 +29,21 @@ sig
val hash: 'a t -> int
val compare: 'a t -> 'a t -> int
external get: 'a t -> 'a elem list = "%identity"
val singleton: 'a elem -> 'a t
val iter: ('a elem -> unit) -> 'a t -> unit
val filter: ('a elem -> bool) -> 'a t -> 'a t
val exists: ('a elem -> bool) -> 'a t -> bool
val fold: ('b -> 'a elem -> 'b) -> 'b -> 'a t -> 'b
val pick: 'a t -> 'a elem option
val length: 'a t -> int
val empty: 'a t
val is_empty: 'a t -> bool
val from_list : 'a elem list -> 'a t
val add: 'a elem -> 'a t -> 'a t
val remove: 'a elem -> 'a t -> 'a t
val disjoint: 'a t -> 'a t -> bool
val cup: 'a t -> 'a t -> 'a t
val split: 'a t -> 'a t -> 'a t * 'a t * 'a t
......@@ -26,9 +55,30 @@ sig
val mem: 'a t -> 'a elem -> bool