Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
c77c6afd
Commit
c77c6afd
authored
Oct 05, 2007
by
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
Changes
6
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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment