Skip to content

GitLab

Commit c77c6afd authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-30 02:41:41 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-10-30 02:41:41+00:00
parent f1fd9ccc
Hide whitespace changes
Inline Side-by-side
Makefile
View file @ c77c6afd
......@@ -20,6 +20,8 @@ RUNTIME = runtime/value.cmo
DRIVER = driver/cduce.cmo
TOPLEVEL = toplevel/toploop.cmo
OBJECTS = $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
XOBJECTS = $(OBJECTS:.cmo=.cmx)
XDRIVER = $(DRIVER:.cmo=.cmx)
......@@ -49,6 +51,10 @@ all.cmxa: $(XOBJECTS)
cduce: $(OBJECTS) $(DRIVER)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(OBJECTS) $(DRIVER)
toplevel: $(OBJECTS) $(TOPLEVEL)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(OBJECTS) $(TOPLEVEL)
cduce.opt: all.cmxa $(XDRIVER)
$(OCAMLOPT) -linkpkg -o $@ gramlib.cmxa $(XOBJECTS) $(XDRIVER)
......
parser/parser.ml
View file @ c77c6afd
......@@ -105,7 +105,7 @@ EXTEND
];
seq_elem: [
[ x = [CHAR | STRING] -> char_list loc x
[ x = CHAR -> char_list loc x
| e = expr LEVEL "no_appl" -> [e]
]
];
......@@ -213,6 +213,16 @@ EXTEND
"]" -> mk loc (Regexp (r,q))
| "<"; t = tag_spec; a = attrib_spec; ">"; c = pat ->
multi_prod loc [t;a;c]
| s = STRING ->
let s = seq_of_string (Token.eval_string s) in
let s = List.map
(fun c ->
mk loc (Internal
(Types.char
(Chars.atom
(Chars.Unichar.from_char c))))) s in
let s = s @ [mk loc (Internal (Sequence.nil_type))] in
multi_prod loc s
]
];
......
tests/addrbook.cd
View file @ c77c6afd
......@@ -6,44 +6,14 @@ type Tel = <tel>[String];;
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
<name>["Benjamin Pierce"]
<addr>["Philadelphia"]
<tel>["123-456-789"]
<name>["Peter Buneman"]
<addr>["Scotland"]
<name>"Haruo Hosoya"
<addr>"Tokyo"
<name>"Benjamin Pierce"
<addr>"Philadelphia"
<tel>"123-456-789"
<name>"Peter Buneman"
<addr>"Scotland"
];;
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
<name>["Benjamin Pierce"]
<addr>["Philadelphia"]
<tel>["123-456-789"]
<name>["Peter Buneman"]
<addr>["Scotland"]
];;
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
<name>["Benjamin Pierce"]
<addr>["Philadelphia"]
<tel>["123-456-789"]
<name>["Peter Buneman"]
<addr>["Scotland"]
];;
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
<name>["Benjamin Pierce"]
<addr>["Philadelphia"]
<tel>["123-456-789"]
<name>["Peter Buneman"]
<addr>["Scotland"]
];;
(*
(* converting an address book into a telephone list *)
......@@ -56,43 +26,27 @@ fun mkTelList ([ (Name Addr Tel?)* ] -> [ (Name Tel)* ])
fun mkTelList (Addrbook -> [ (Name Tel)* ])
<_>[ ( ( (x::Name) Addr (x::Tel) ) | _ )* ] -> x
;;
*)
fun (Int -> Addrbook) x ->
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
<name>["Benjamin Pierce"]
<addr>["Philadelphia"]
<tel>["123-456-789"]
<name>["Peter Buneman"]
<addr>["Scotland"]
<name>"Haruo Hosoya"
<addr>"Tokyo"
<name>"Benjamin Pierce"
<addr>"Philadelphia"
<tel>"123-456-789"
<name>"Peter Buneman"
<addr>"Scotland"
]
;;
(*
fun (Int -> Addrbook) x ->
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
<name>["Benjamin Pierce"]
<addr>["Philadelphia"]
<tel>["123-456-789"]
<name>["Peter Buneman"]
<addr>["Scotland"]
]
;;
*)
(*
match <addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
<name>["Benjamin Pierce"]
<addr>["Philadelphia"]
<tel>["123-456-789"]
<name>["Peter Buneman"]
<addr>["Scotland"]
<name>"Haruo Hosoya"
<addr>"Tokyo"
<name>"Benjamin Pierce"
<addr>"Philadelphia"
<tel>"123-456-789"
<name>"Peter Buneman"
<addr>"Scotland"
] with
<_>[ ( ( (x::Name) Addr (x::Tel) ) | _ )* ] -> x;;
......@@ -101,4 +55,3 @@ match <addrbook>[
match ex with addrbook:[;a] -> mkTelList a;;
*)
*)
tests/overloading.cd
View file @ c77c6afd
type Person = FPerson | MPerson;;
type FPerson = <person gender='F'>[Name Children ];;
type MPerson = <person gender='M'>[ Name Children];;
type FPerson = <person gender = ['F'] >[ Name Children ];;
type MPerson = <person gender="M">[ Name Children];;
type Children = <children>[Person*];;
type Name = <name>[String];;
......@@ -11,17 +11,19 @@ type Daughters = <daughters>[ Woman* ];;
let fun sort (MPerson -> Man ; FPerson -> Woman)
<person gender=g>[ n <children>[(mc::MPerson | fc::FPerson)*] ] ->
let tag = match g with 'F' -> `woman | 'M' -> `man in
let tag = match g with "F" -> `woman | "M" -> `man in
let s = map mc with x -> sort x in
let d = map fc with x -> sort x in
<(tag)>[ n <sons>s <daughters>d ]
in sort(<person gender='F'>[
<name>["Veronique"]
<children>[
<person gender='F'>[
<name>["Ilaria"]
<children>[]
]
]
]);;
in
let base : Person =
<person gender="F">[
<name>"Veronique"
<children>[
<person gender="F">[
<name>"Ilaria"
<children>[]
]
]
]
in sort base;;
tests/security.cd
View file @ c77c6afd
......@@ -3,33 +3,35 @@ type Worker = <worker>[Surname Name Salary];;
type Surname = <surname>[String];;
type Name = <name>[String];;
type Salary = <salary>[Int];;
type PlusQueMoi = 1000;;
type PlusQueMoi = <salary>[5000--10000000];;
let my_company =
let my_company : Company =
<company>[
<worker>[
<surname>["Durand"]
<name>["Paul"]
<salary>["6500"]
<surname>"Durand"
<name>"Paul"
<salary>[6500]
]
<worker>[
<surname>["Dupond"]
<name>["Jean"]
<surname>"Dupond"
<name>"Jean"
<salary>[1800]
]
<worker>[
<surname>["Martin"]
<name>["Jules"]
<surname>"Martin"
<name>"Jules"
<salary>[1800]
]
] in
let q1 = let <company> x = my_company in
(map x with <worker>[x y z ] -> <worker>[x y]) in
let q1 =
let <company> x = my_company in
map x with <worker>[x y z ] -> <worker>[x y] in
let q2 = let <company>[(x::<worker>[ Any Any PlusQueMoi ])*] = my_company in
(map x with <worker>[x y z ] -> <worker>[x y]) in
let q2 =
let <company>[(x::<worker>[ Any Any PlusQueMoi ] | _)*] = my_company in
map x with <worker>[x y z ] -> <worker>[x y] in
(q1,q2);;
types/recursive.ml
View file @ c77c6afd
(* $Id: recursive.ml,v 1.4 2002/10/30 02:05:41 cvscast Exp $ *)
(* A fast replacement of Recursive without sharing at all *)
exception NotEqual
exception Incomplete
......@@ -18,156 +18,41 @@ end
module Make(X : S) =
struct
type state = Undefined | Defined | Hashed | Intern
(* Two values of this type have either different id or the
same fields (but they are not necessarily == if they have the same id).
This ensures that Pervasives.compare always terminates in O(1). *)
type node_content = {
mutable id : int;
mutable descr : node X.t;
mutable hash : int;
mutable state : state;
mutable hashs : int array;
} and node = node_content ref
type descr = node X.t
(* To avoid the creation of closures when computing hash values.
Need some profiling to see how much we gain, and if
a complete inlining for small values of deep is better *)
let deep_hash_tab = Array.create (X.deep + 1)
(fun {contents=n} ->
if n.state = Undefined then raise Incomplete;
13
)
let _ =
for i = 1 to X.deep do
deep_hash_tab.(i) <-
(fun {contents=n} ->
if n.hashs.(i) <> max_int then n.hashs.(i) else
(if n.state = Undefined then raise Incomplete;
let r = X.hash deep_hash_tab.(i-1) n.descr in
let r = if r = max_int then max_int - 1 else r in
n.hashs.(i) <- r;
r)
)
done
let deep_hash = deep_hash_tab.(X.deep)
(*
let rec deep_hash_rec k n =
if n.state = Undefined then raise Incomplete;
if k = 0 then 1 else X.hash (deep_hash_rec (k-1)) n.descr
let deep_hash = deep_hash_rec X.deep *)
let hash ({contents=n} as nr) =
match n.state with
| Defined ->
n.hash <- (deep_hash nr) land max_int;
(* Up to OCaml 3.04, Hashtbl.Make requires hash to return
non-negative integers ... *)
n.state <- Hashed;
n.hash
| Undefined -> raise Incomplete
| Hashed | Intern -> n.hash
let id n = !n.id
type state = Undefined | Defined
type node = {
id : int;
mutable descr : descr;
}
and descr = node X.t
let id n = n.id
let counter = ref 0
let make () =
incr counter;
ref {
{
id = !counter;
descr = Obj.magic 0;
state = Undefined;
hash = 0;
hashs = Array.make (X.deep+1) max_int;
}
let c = Hashtbl.create 64
let rec equal_rec a b =
if (a != b) then
if (hash a <> hash b) then raise NotEqual else
let a = !a and b = !b in
if (a != b) then
match (a.state,b.state) with
| (Intern,Intern) -> raise NotEqual
| _ ->
let m = if a.id < b.id then (a.id,b.id) else (b.id,a.id) in
if not (Hashtbl.mem c m) then
(Hashtbl.add c m (); X.equal equal_rec a.descr b.descr)
let equal ({contents=a} as ar) ({contents=b} as br) =
match (a.state,b.state) with
| (Intern,Intern) -> a.id = b.id
| _ ->
let r = try equal_rec ar br; true with NotEqual -> false in
Hashtbl.clear c;
r
(* Possible optimization: if r = true, one knows
that all pairs in c are equal. Could merge them here ? *)
module Prehash = Hashtbl.Make
(struct
type t = node
let hash = hash
let equal = equal
end)
let known = Prehash.create 1023
let rec internalize (({contents=n} as nr) : node) =
match n.state with
| Intern -> nr
| Undefined -> raise Incomplete
| Hashed
| Defined ->
(
try
let m = Prehash.find known nr in
nr := m;
nr
with Not_found ->
n.state <- Intern;
Prehash.add known nr n
;
n.descr <- X.map internalize n.descr;
nr
(* Cannot change descr ! If copied to another node, this would break (=) !!! *)
)
let internalize_descr = X.map internalize
let descr {contents=n} =
if n.state = Undefined then raise Incomplete else n.descr
let define ({contents=n} as nr) d =
if n.state != Undefined then failwith "Already defined";
n.state <- Defined;
n.descr <- d;
(* Special support for bottom-up hash-consing non-recursive objects *)
try
X.iter (fun m -> if !m.state <> Intern then raise Exit) d;
ignore (internalize nr)
with Exit -> ()
let hash_descr d = X.hash (fun n -> !n.id) d
let equal x y = x.id = y.id
let internalize n = n
let internalize_descr d = d
let descr n = n.descr
let define n d = n.descr <- d
let hash_descr d = X.hash (fun n -> n.id) d
let equal_descr d1 d2 =
(d1 == d2) ||
try
X.equal
(fun n1 n2 -> if !n1.id <> !n2.id then raise NotEqual)
(fun n1 n2 -> if n1.id <> n2.id then raise NotEqual)
d1 d2;
true
with NotEqual -> false
......
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