Commit 2dd2c835 authored by Pietro Abate's avatar Pietro Abate

[r2003-03-07 17:31:04 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-07 17:31:05+00:00
parent 61c922b2
......@@ -45,7 +45,7 @@ DEBUG = -g
PACKAGES = pxp-engine,pxp-lex-iso88591,wlexing,camlp4,num,cgi
OCAMLCP = ocamlc
OCAMLC = ocamlfind $(OCAMLCP) -package $(PACKAGES)
OCAMLOPT = ocamlfind ocamlopt -package $(PACKAGES)
OCAMLOPT = ocamlfind ocamlopt -package $(PACKAGES)
DEPEND = $(DIRS:=/*.ml) $(DIRS:=/*.mli)
INCLUDES = $(DIRS:%=-I %)
......
......@@ -49,7 +49,8 @@ struct
let value n = match !values.(n) with Some x -> x | None -> assert false
let compare (n1 : int) (n2 : int) = Pervasives.compare n1 n2
let compare (n1 : int) (n2 : int) =
if n1 < n2 then -1 else if n1 = n2 then 0 else 1
let hash n = n
let equal (n1 : int) (n2 : int) = n1 = n2
end
......
......@@ -23,5 +23,5 @@ sig
val equal: t -> t -> bool
end
module Make(H : Hashtbl.HashedType) : T with type value = H.t
module Make(H : Hashtbl.HashedType) : T with type value = H.t and type t = int
......@@ -51,7 +51,7 @@ let parse_char loc s =
let char_list pos s =
let s = seq_of_string pos s in
List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.Unichar.from_char c)))) s
List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.mk_char c)))) s
EXTEND
......@@ -153,7 +153,7 @@ EXTEND
| `Explode x -> mk x.loc (Op ("@",[x;q]))
) l e
| t = [ a = TAG ->
mk loc (Cst (Types.Atom (Types.AtomPool.mk a)))
mk loc (Cst (Types.Atom (Atoms.mk a)))
| "<"; e = expr LEVEL "no_appl" -> e ];
a = expr_attrib_spec; ">"; c = expr ->
mk loc (Xml (t, mk loc (Pair (a,c))))
......@@ -238,14 +238,14 @@ EXTEND
| "("; a = LIDENT; ":="; c = const; ")" -> Elem (mk loc (Constant (a,c)))
| UIDENT "PCDATA" -> string_regexp
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.Unichar.from_char (parse_char loc i)
and j = Chars.Unichar.from_char (parse_char loc j) in
let i = Chars.mk_char (parse_char loc i)
and j = Chars.mk_char (parse_char loc j) in
Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
| s = STRING1 ->
let s = seq_of_string loc s in
List.fold_right
(fun (loc,c) accu ->
let c = Chars.Unichar.from_char c in
let c = Chars.mk_char c in
let c = Chars.atom c in
Seq (Elem (mk loc (Internal (Types.char c))), accu))
s
......@@ -270,17 +270,17 @@ EXTEND
| "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
| a = UIDENT -> mk loc (PatVar a)
| i = INT ; "--"; j = INT ->
let i = Big_int.big_int_of_string i
and j = Big_int.big_int_of_string j in
let i = Intervals.mk i
and j = Intervals.mk j in
mk loc (Internal (Types.interval (Intervals.bounded i j)))
| i = INT ->
let i = Big_int.big_int_of_string i in
let i = Intervals.mk i in
mk loc (Internal (Types.interval (Intervals.atom i)))
| "*"; "--"; j = INT ->
let j = Big_int.big_int_of_string j in
let j = Intervals.mk j in
mk loc (Internal (Types.interval (Intervals.left j)))
| i = INT; "--"; "*" ->
let i = Big_int.big_int_of_string i in
let i = Intervals.mk i in
mk loc (Internal (Types.interval (Intervals.right i)))
| i = char ->
mk loc (Internal (Types.char (Chars.char_class i i)))
......@@ -296,7 +296,7 @@ EXTEND
[ "<"; LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any)))
| a = TAG ->
mk loc
(Internal (Types.atom (Atoms.atom (Types.AtomPool.mk a)))) ]
(Internal (Types.atom (Atoms.atom (Atoms.mk a)))) ]
| [ "<"; t = pat -> t ]
];
a = attrib_spec; ">"; c = pat ->
......@@ -308,7 +308,7 @@ EXTEND
mk loc (Internal
(Types.char
(Chars.atom
(Chars.Unichar.from_char c))))) s in
(Chars.mk_char c))))) s in
let s = s @ [mk loc (Internal (Sequence.nil_type))] in
multi_prod loc s
]
......@@ -326,15 +326,15 @@ EXTEND
char:
[
[ c = STRING1 -> Chars.Unichar.from_char (parse_char loc c)
| "!"; i = INT -> Chars.Unichar.from_int (int_of_string i) ]
[ c = STRING1 -> Chars.mk_char (parse_char loc c)
| "!"; i = INT -> Chars.mk_int (int_of_string i) ]
];
const:
[
[ i = INT -> Types.Integer (Big_int.big_int_of_string i)
| "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.AtomPool.mk a)
[ i = INT -> Types.Integer (Intervals.mk i)
| "`"; a = [LIDENT | UIDENT] -> Types.Atom (Atoms.mk a)
| c = char -> Types.Char c ]
];
......
......@@ -9,7 +9,7 @@ let enter_global x v = global_env := Env.add x v !global_env
let exn_int_of = CDuceExn (Pair (
Atom (Types.AtomPool.mk "Invalid_argument"),
Atom (Atoms.mk "Invalid_argument"),
string "int_of"))
......@@ -115,23 +115,23 @@ and eval_dot l = function
| _ -> assert false
and eval_add x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
| (Integer x, Integer y) -> Integer (Intervals.vadd x y)
| _ -> assert false
and eval_mul x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
| (Integer x, Integer y) -> Integer (Intervals.vmult x y)
| _ -> assert false
and eval_sub x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
| (Integer x, Integer y) -> Integer (Intervals.vsub x y)
| _ -> assert false
and eval_div x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
| (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
| _ -> assert false
and eval_mod x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.mod_big_int x y)
| (Integer x, Integer y) -> Integer (Intervals.vmod x y)
| _ -> assert false
and eval_load_xml e =
......@@ -142,7 +142,7 @@ and eval_load_html e =
and eval_int_of e =
let s = get_string e in
try Integer (Big_int.big_int_of_string s)
try Integer (Intervals.mk s)
with Failure _ -> raise exn_int_of
and eval_print_xml v =
......
......@@ -24,7 +24,7 @@ let attrib att =
SortedMap.from_list (fun _ _ -> assert false) att
let elem tag att child =
Xml (Atom (Types.AtomPool.mk tag), Pair (Record (attrib att), child))
Xml (Atom (Atoms.mk tag), Pair (Record (attrib att), child))
let load_xml_aux s =
let config = { default_config with
......
......@@ -5,7 +5,7 @@ open Pxp_types
open Value
let exn_print_xml = CDuceExn (Pair (
Atom (Types.AtomPool.mk "Invalid_argument"),
Atom (Atoms.mk "Invalid_argument"),
string "print_xml"))
......@@ -42,7 +42,7 @@ let string_of_xml v=
let rec print_elt = function
| Xml (Atom tag, Pair (Record attrs, content)) ->
let tag = Types.AtomPool.value tag in
let tag = Atoms.value tag in
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 in
......@@ -53,7 +53,7 @@ let string_of_xml v=
print_content content;
element_end tag)
| Char x ->
wds (String.make 1 (Chars.Unichar.to_char x)); (* TODO: opt *)
wds (String.make 1 (Chars.to_char x)); (* TODO: opt *)
| _ -> raise exn_print_xml
and print_content = function
| String (i,j,s,q) ->
......
......@@ -2,9 +2,9 @@ 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
| Char of Chars.Unichar.t
| Atom of Atoms.v
| Integer of Intervals.v
| Char of Chars.v
| Abstraction of (Types.descr * Types.descr) list * (t -> t)
| String of int * int * string * t
......@@ -25,7 +25,7 @@ let get_string e =
| String (i,j,_,y) -> compute_len (accu + j - i) y
| _ -> accu in
let rec fill pos s = function
| Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
| Pair (Char x,y) -> s.[pos] <- Chars.to_char x; fill (pos + 1) s y
| String (i,j,src,y) ->
String.blit src i s pos (j - i); fill (pos + j - i) s y
| _ -> s in
......@@ -54,15 +54,15 @@ let rec print ppf v =
| 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)
| Char c -> Chars.Unichar.print ppf c
| Atom a -> Atoms.print_v ppf a
| Integer i -> Intervals.print_v ppf i
| Char c -> Chars.print_v ppf c
| Abstraction _ -> Format.fprintf ppf "<fun>"
| String (i,j,s,q) ->
Format.fprintf ppf "<string:%i-%i,%S,%a>" i j s print q
and print_quoted_str ppf = function
| Pair (Char c, q) ->
Chars.Unichar.print_in_string ppf c;
Chars.print_v_in_string ppf c;
print_quoted_str ppf q
| String (i,j,s, q) ->
Format.fprintf ppf "%s" (String.escaped (String.sub s i (j-i)));
......@@ -80,7 +80,7 @@ and print_seq ppf = function
| _ -> ()
and print_str ppf = function
| Pair (Char c,y) ->
let c = Chars.Unichar.to_char c in
let c = Chars.to_char c in
Format.fprintf ppf "%s" (Char.escaped c);
print_str ppf y
| v ->
......@@ -90,7 +90,7 @@ and print_str ppf = function
and print_xml ppf = function
| (Atom tag, Pair (Record attr,content)) ->
Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]"
(Types.AtomPool.value tag)
(Atoms.value tag)
print_record attr
print_seq content
| _ -> assert false
......@@ -107,6 +107,5 @@ and print_field ppf (l,v) =
let normalize = function
| String (i,j,s,q) ->
if i = j then q else
Pair (Char (Chars.Unichar.from_char s.[i]),
String (succ i,j,s,q))
Pair (Char (Chars.mk_char s.[i]), String (succ i,j,s,q))
| v -> assert false
......@@ -3,9 +3,9 @@ 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
| Char of Chars.Unichar.t
| Atom of Atoms.v
| Integer of Intervals.v
| Char of Chars.v
| Abstraction of (Types.descr * Types.descr) list * (t -> t)
(* Derived forms *)
......
......@@ -2,9 +2,10 @@ let fun facto (Int -> Int)
| 0 | 1 -> 1
| n -> n * (facto (n - 1))
in
facto 300;;
facto 10000;;
(*
type Pos = 0--*;;
let fun abs (Int -> Pos)
......@@ -34,3 +35,4 @@ let fun eval ( Expr -> Int )
| n -> n
in
eval (`add, 10, (`add, 20, 5));;
*)
......@@ -16,10 +16,10 @@ debug compile T
({ c = c } | ( c := `B)) &
({ d = d } | ( d := `B)) &
({ e = e } | ( e := `B)) &
({ f = f } | ( f := `B)) &
(* ({ f = f } | ( f := `B)) &
({ g = g } | ( g := `B)) &
({ h = h } | ( h := `B)) &
({ i = i } | ( i := `B)) &
({ i = i } | ( i := `B)) & *)
(* ({ j = j } | ( j := `B)) &
({ k = k } | ( k := `B)) &
({ l = l } | ( l := `B)) &
......
type 'a t = Finite of 'a list | Cofinite of 'a list
module HashedString =
struct
type t = string
let hash = Hashtbl.hash
let equal = (=)
end
module AtomPool = Pool.Make(HashedString)
type v = AtomPool.t
let value = AtomPool.value
let mk = AtomPool.mk
type t = Finite of v list | Cofinite of v list
let empty = Finite []
let any = Cofinite []
......@@ -38,23 +50,46 @@ let is_atom = function
| Finite [a] -> Some a
| _ -> None
let sample except = function
let sample = function
| Finite (x :: _) -> x
| Cofinite l -> except l
| Cofinite l -> AtomPool.dummy_min
| Finite [] -> raise Not_found
let print_v ppf a =
if a = AtomPool.dummy_min then
Format.fprintf ppf "(almost any atom)"
else
Format.fprintf ppf "`%s" (value a)
let print any f = function
| Finite l -> List.map (fun x ppf -> f ppf x) l
let print = function
| Finite l -> List.map (fun x ppf -> print_v ppf x) l
| Cofinite [] ->
[ fun ppf -> Format.fprintf ppf "%s" any ]
[ fun ppf -> Format.fprintf ppf "Atom" ]
| Cofinite [h] ->
[ fun ppf -> Format.fprintf ppf "@[%s - %a@]" any f h ]
[ fun ppf -> Format.fprintf ppf "@[Atom - %a@]" print_v h ]
| Cofinite (h::t) ->
[ fun ppf ->
Format.fprintf ppf "@[%s - (" any;
f ppf h;
List.iter (fun x -> Format.fprintf ppf " |@ %a" f x) t;
Format.fprintf ppf "@[Atom - (";
print_v ppf h;
List.iter (fun x -> Format.fprintf ppf " |@ %a" print_v x) t;
Format.fprintf ppf ")@]" ]
let rec hash_seq accu = function
| t::rem -> hash_seq (accu * 17 + t) rem
| [] -> accu
let hash accu = function
| Finite l -> hash_seq (accu + 1) l
| Cofinite l -> hash_seq (accu + 3) l
let rec equal_rec l1 l2 =
(l1 == l2) ||
match (l1,l2) with
| (x1::l1,x2::l2) -> (x1 == x2) && (equal_rec l1 l2)
| _ -> false
let equal t1 t2 = match (t1,t2) with
| (Finite l1, Finite l2) -> equal_rec l1 l2
| (Cofinite l1, Cofinite l2) -> equal_rec l1 l2
| _ -> false
type 'a t (* = Finite of 'a list | Cofinite of 'a list *)
type v
val value: v -> string
val mk: string -> v
val print_v: Format.formatter -> v -> unit
val empty : 'a t
val any : 'a t
val cup : 'a t -> 'a t -> 'a t
val cap : 'a t -> 'a t -> 'a t
val diff : 'a t -> 'a t -> 'a t
val atom : 'a -> 'a t
type t
val hash: int -> t -> int
val equal: t -> t -> bool
val print : t -> (Format.formatter -> unit) list
val empty : t
val any : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : v -> t
val contains : v -> t -> bool
val is_empty : t -> bool
val is_atom : t -> v option
val sample : t -> v
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 ->
(Format.formatter -> unit) list
......@@ -20,16 +20,18 @@ let cup t s =
List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in
SortedList.cup s t
let clean t =
let tot = ref 0
let clean accu t =
let rec aux accu = function
| (p,n) :: rem ->
if (List.exists (may_remove (p,n)) accu)
|| (List.exists (may_remove (p,n)) rem)
then aux accu rem
else aux((p,n) :: accu) rem
| [] -> accu
else aux ((p,n)::accu) rem
| [] -> accu
in
List.rev (aux [] t)
SortedList.from_list (aux accu t)
......@@ -49,17 +51,12 @@ let cap s t =
else if (s == empty) || (t == empty) then empty
else
let (lines1,common,lines2) = SortedList.split s t in
let lines =
fold2
(fun lines (p1,n1) (p2,n2) ->
if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1)
then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
else lines)
[]
lines1
lines2
let rec aux lines (p1,n1) (p2,n2) =
if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1)
then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
else lines
in
clean (SortedList.cup common (SortedList.from_list lines))
clean common (fold2 aux [] lines1 lines2)
let diff c1 c2 =
if c2 == full then empty
......
let intstr =
Sequence.plus (Types.char (Chars.char_class
(Chars.Unichar.from_char '0')
(Chars.Unichar.from_char '9')
(Chars.mk_char '0')
(Chars.mk_char '9')
)
)
......
module Unichar = struct
type t = int
type v = int
let max = 0x10FFFF
let max_char = 0x10FFFF
let from_int c =
if (c < 0) || (c > max) then
failwith "Chars.from_int: code point out of bound";
c
let from_char c =
Char.code c
let mk_int c =
if (c < 0) || (c > max_char) then
failwith "Chars.mk_int: code point out of bound";
c
let to_int c = c
let mk_char c =
Char.code c
let to_int c = c
let to_char c =
if (c > 255) then failwith "to_char: code-point > 255";
Char.chr c
let to_char c =
if (c > 255) then failwith "Chars.to_char: code-point > 255";
Char.chr c
let print ppf c =
if (c < 128)
then Format.fprintf ppf "%C" (Char.chr c)
else Format.fprintf ppf "#x%x" c
let print_v ppf c =
if (c < 128)
then Format.fprintf ppf "%C" (Char.chr c)
else Format.fprintf ppf "#x%x" c
let print_in_string ppf c =
Format.fprintf ppf "%c" (Char.chr c)
end
let print_v_in_string ppf c =
Format.fprintf ppf "%c" (Char.chr c)
type t = (v * v) list
type t = (Unichar.t * Unichar.t) list
let rec hash accu = function
| (i,j)::rem -> hash (accu * 257 + i * 17 + j) rem
| [] -> accu + 3
let max_char = Unichar.max
let rec equal l1 l2 =
(l1 == l2) ||
match (l1,l2) with
| (i1,j1)::l1, (i2,j2)::l2 -> (i1==i2) && (j1==j2) && (equal l1 l2)
| _ -> false
let from_int c =
if (c < 0) || (c > max_char) then
......@@ -84,8 +90,8 @@ let print =
(fun (a,b) ->
if a = b
then fun ppf ->
Unichar.print ppf a
print_v ppf a
else fun ppf ->
if a = 0 && b = max_char then Format.fprintf ppf "Char" else
Format.fprintf ppf "%a--%a" Unichar.print a Unichar.print b
Format.fprintf ppf "%a--%a" print_v a print_v b
)
module Unichar : sig
type t
val from_int: int -> t
val from_char: char -> t
val to_int: t -> int
val to_char: t -> char
type v
val mk_int: int -> v
val mk_char: char -> v
val to_int: v -> int
val to_char: v -> char
val print_v : Format.formatter -> v -> unit
val print_v_in_string : Format.formatter -> v -> unit
val print : Format.formatter -> t -> unit
val print_in_string : Format.formatter -> t -> unit
end
type t = (Unichar.t * Unichar.t) list
type t (* = (Unichar.t * Unichar.t) list *)
val equal : t -> t -> bool
val hash : int -> t -> int
val print : t -> (Format.formatter -> unit) list
val empty : t
val any : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val char_class : Unichar.t -> Unichar.t -> t
val atom : Unichar.t -> t
val char_class : v -> v -> t
val atom : v -> t
val is_empty : t -> bool
val contains : Unichar.t -> t -> bool
val sample : t -> Unichar.t
val contains : v -> t -> bool
val sample : t -> v
val print : t -> (Format.formatter -> unit) list
open Big_int
type v = big_int
let print_v ppf i = Format.fprintf ppf "%s" (string_of_big_int i)
let mk = big_int_of_string
let vadd = add_big_int
let vmult = mult_big_int
let vsub = sub_big_int
let vdiv = div_big_int
let vmod = mod_big_int
type interval =
| Bounded of big_int * big_int
| Left of big_int
......@@ -25,15 +35,18 @@ let rec equal l1 l2 =
| ([], []) -> true
| _ -> false
let hash = function
| Bounded (a,b) :: _ ->
1 + 2 * (num_digits_big_int a) + 3 *