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
12c7039b
Commit
12c7039b
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-10-16 16:18:48 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-16 16:18:48+00:00
parent
2ff9b09e
Changes
9
Hide whitespace changes
Inline
Side-by-side
depend
View file @
12c7039b
...
...
@@ -2,10 +2,10 @@ 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/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo
parser/location.cmi types/types
.cmi \
parser/parser.cmi
parser/parser.cmx: parser/ast.cmx
parser/location.cmx types/types
.cmx \
parser/parser.cmi
parser/parser.cmo: parser/ast.cmo
types/chars.cmi parser/location
.cmi \
types/types.cmi
parser/parser.cmi
parser/parser.cmx: parser/ast.cmx
types/chars.cmx parser/location
.cmx \
types/types.cmx
parser/parser.cmi
parser/parser.cmi: parser/ast.cmo
typing/typed.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
typing/typed.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
...
...
@@ -38,17 +38,17 @@ types/strings.cmx: types/boolean.cmx types/intervals.cmx types/recursive.cmx \
types/strings.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmi
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/
interval
s.cmi \
types/recursive.cmi types/sortedList.cmi
types/sortedMap.cmi
\
types/strings.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/
interval
s.cmx \
types/recursive.cmx types/sortedList.cmx
types/sortedMap.cmx
\
types/strings.cmx types/types.cmi
types/types.cmo: types/atoms.cmi types/boolean.cmi types/
char
s.cmi \
types/intervals.cmi
types/recursive.cmi types/sortedList.cmi \
types/sortedMap.cmi
types/strings.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/
char
s.cmx \
types/intervals.cmx
types/recursive.cmx types/sortedList.cmx \
types/sortedMap.cmx
types/strings.cmx types/types.cmi
types/boolean.cmi: types/sortedList.cmi
types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/sortedMap.cmi types/strings.cmi
types/types.cmi:
types/chars.cmi
types/sortedMap.cmi types/strings.cmi
driver/cduce.cmo: parser/ast.cmo parser/location.cmi parser/parser.cmi \
typing/typer.cmi types/types.cmi
driver/cduce.cmx: parser/ast.cmx parser/location.cmx parser/parser.cmx \
...
...
driver/cduce.ml
View file @
12c7039b
...
...
@@ -28,9 +28,19 @@ let phrase ph =
let
(
fv
,
e
)
=
Typer
.
expr
e
in
let
t
=
Typer
.
compute_type
Typer
.
Env
.
empty
e
in
Format
.
fprintf
ppf
"%a@
\n
"
Types
.
Print
.
print_descr
t
;
|
Ast
.
TypeDecl
_
->
()
|
_
->
assert
false
let
()
=
try
List
.
iter
phrase
(
prog
()
)
try
let
p
=
prog
()
in
let
type_decls
=
List
.
fold_left
(
fun
accu
ph
->
match
ph
.
descr
with
|
Ast
.
TypeDecl
(
x
,
t
)
->
(
x
,
t
)
::
accu
|
_
->
accu
)
[]
p
in
Typer
.
register_global_types
type_decls
;
List
.
iter
phrase
p
with
exn
->
print_exn
ppf
exn
parser/parser.ml
View file @
12c7039b
...
...
@@ -24,7 +24,12 @@ open Ast
GLOBAL
:
prog
expr
pat
regexp
const
;
prog
:
[
[
l
=
LIST0
[
e
=
expr
;
";;"
->
mk
loc
(
EvalStatement
e
)
]
->
l
]
[
l
=
LIST0
[
p
=
phrase
;
";;"
->
mk
loc
p
];
";;"
->
l
]
];
phrase
:
[
[
e
=
expr
->
EvalStatement
e
|
"type"
;
x
=
UIDENT
;
"="
;
t
=
pat
->
TypeDecl
(
x
,
t
)
]
];
expr
:
[
...
...
@@ -114,6 +119,8 @@ open Ast
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
int_of_string
i
and
j
=
int_of_string
j
in
mk
loc
(
Internal
(
Types
.
interval
i
j
))
|
i
=
char
;
"--"
;
j
=
char
->
mk
loc
(
Internal
(
Types
.
char_class
i
j
))
|
c
=
const
->
mk
loc
(
Internal
(
Types
.
constant
c
))
|
"("
;
l
=
LIST1
pat
SEP
","
;
")"
->
multi_prod
loc
l
|
"["
;
r
=
[
r
=
regexp
->
r
|
->
Epsilon
];
...
...
@@ -137,11 +144,19 @@ open Ast
|
h
::
t
->
List
.
fold_left
(
fun
t1
t2
->
mk
loc
(
And
(
t1
,
t2
)))
h
t
]
];
char
:
[
[
c
=
CHAR
->
Chars
.
Unichar
.
from_char
(
Token
.
eval_char
c
)
|
"!"
;
i
=
INT
->
Chars
.
Unichar
.
from_int
(
int_of_string
i
)
]
];
const
:
[
[
i
=
INT
->
Types
.
Integer
(
int_of_string
i
)
|
x
=
STRING
->
Types
.
String
(
Token
.
eval_string
x
)
|
"`"
;
a
=
[
LIDENT
|
UIDENT
]
->
Types
.
Atom
(
Types
.
mk_atom
a
)
]
|
"`"
;
a
=
[
LIDENT
|
UIDENT
]
->
Types
.
Atom
(
Types
.
mk_atom
a
)
|
c
=
char
->
Types
.
Char
c
]
];
tag_spec
:
...
...
types/chars.ml
View file @
12c7039b
...
...
@@ -8,6 +8,9 @@ module Unichar = struct
failwith
"Chars.from_int: code point out of bound"
;
c
let
from_char
c
=
Char
.
code
c
let
to_int
c
=
c
let
print
ppf
c
=
...
...
@@ -30,8 +33,9 @@ let to_int c = c
let
empty
=
[]
let
full
=
[
0
,
max_char
]
let
char_class
(
a
,
b
)
=
if
a
<=
b
then
[
a
,
b
]
else
empty
let
char_class
a
b
=
if
a
<=
b
then
[
a
,
b
]
else
empty
let
atom
a
=
[
a
,
a
]
let
rec
add
l
((
a
,
b
)
as
i
)
=
match
l
with
|
[]
->
...
...
types/chars.mli
View file @
12c7039b
module
Unichar
:
sig
type
t
val
from_int
:
int
->
t
val
from_char
:
char
->
t
val
to_int
:
t
->
int
val
print
:
Format
.
formatter
->
t
->
unit
end
...
...
@@ -12,7 +14,8 @@ val full : 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
char_class
:
Unichar
.
t
->
Unichar
.
t
->
t
val
atom
:
Unichar
.
t
->
t
val
is_empty
:
t
->
bool
...
...
types/types.ml
View file @
12c7039b
...
...
@@ -6,7 +6,7 @@ open Printf
type
label
=
int
type
atom
=
int
type
const
=
Integer
of
int
|
Atom
of
atom
|
String
of
string
type
const
=
Integer
of
int
|
Atom
of
atom
|
String
of
string
|
Char
of
Chars
.
Unichar
.
t
module
I
=
struct
type
'
a
t
=
{
...
...
@@ -15,6 +15,7 @@ module I = struct
times
:
(
'
a
*
'
a
)
Boolean
.
t
;
arrow
:
(
'
a
*
'
a
)
Boolean
.
t
;
record
:
(
label
*
bool
*
'
a
)
Boolean
.
t
;
chars
:
Chars
.
t
;
strs
:
Strings
.
t
;
}
...
...
@@ -24,6 +25,7 @@ module I = struct
record
=
Boolean
.
empty
;
ints
=
Intervals
.
empty
;
atoms
=
Atoms
.
empty
;
chars
=
Chars
.
empty
;
strs
=
Strings
.
empty
;
}
let
any
=
{
...
...
@@ -32,6 +34,7 @@ module I = struct
record
=
Boolean
.
full
;
ints
=
Intervals
.
full
;
atoms
=
Atoms
.
full
;
chars
=
Chars
.
full
;
strs
=
Strings
.
any
;
}
...
...
@@ -41,10 +44,13 @@ module I = struct
let
record
label
opt
t
=
{
empty
with
record
=
Boolean
.
atom
(
label
,
opt
,
t
)
}
let
atom
a
=
{
empty
with
atoms
=
Atoms
.
atom
a
}
let
string
r
=
{
empty
with
strs
=
Strings
.
Regexp
.
compile
r
}
let
char
c
=
{
empty
with
chars
=
Chars
.
atom
c
}
let
char_class
c1
c2
=
{
empty
with
chars
=
Chars
.
char_class
c1
c2
}
let
constant
=
function
|
Integer
i
->
interval
i
i
|
Atom
a
->
atom
a
|
String
s
->
string
(
Strings
.
Regexp
.
str
s
)
|
Char
c
->
char
c
let
any_record
=
{
empty
with
record
=
any
.
record
}
...
...
@@ -56,6 +62,7 @@ module I = struct
record
=
Boolean
.
cup
x
.
record
y
.
record
;
ints
=
Intervals
.
cup
x
.
ints
y
.
ints
;
atoms
=
Atoms
.
cup
x
.
atoms
y
.
atoms
;
chars
=
Chars
.
cup
x
.
chars
y
.
chars
;
strs
=
Strings
.
cup
x
.
strs
y
.
strs
;
}
...
...
@@ -66,6 +73,7 @@ module I = struct
arrow
=
Boolean
.
cap
x
.
arrow
y
.
arrow
;
ints
=
Intervals
.
cap
x
.
ints
y
.
ints
;
atoms
=
Atoms
.
cap
x
.
atoms
y
.
atoms
;
chars
=
Chars
.
cap
x
.
chars
y
.
chars
;
strs
=
Strings
.
cap
x
.
strs
y
.
strs
;
}
...
...
@@ -76,6 +84,7 @@ module I = struct
record
=
Boolean
.
diff
x
.
record
y
.
record
;
ints
=
Intervals
.
diff
x
.
ints
y
.
ints
;
atoms
=
Atoms
.
diff
x
.
atoms
y
.
atoms
;
chars
=
Chars
.
diff
x
.
chars
y
.
chars
;
strs
=
Strings
.
diff
x
.
strs
y
.
strs
;
}
...
...
@@ -84,6 +93,7 @@ module I = struct
let
equal
e
a
b
=
if
a
.
ints
<>
b
.
ints
then
raise
NotEqual
;
if
a
.
atoms
<>
b
.
atoms
then
raise
NotEqual
;
if
a
.
chars
<>
b
.
chars
then
raise
NotEqual
;
if
a
.
strs
<>
b
.
strs
then
raise
NotEqual
;
Boolean
.
equal
(
fun
(
x1
,
x2
)
(
y1
,
y2
)
->
e
x1
y1
;
e
x2
y2
)
a
.
times
b
.
times
;
Boolean
.
equal
(
fun
(
x1
,
x2
)
(
y1
,
y2
)
->
e
x1
y1
;
e
x2
y2
)
a
.
arrow
b
.
arrow
;
...
...
@@ -97,6 +107,7 @@ module I = struct
record
=
Boolean
.
map
(
fun
(
l
,
o
,
x
)
->
(
l
,
o
,
f
x
))
a
.
record
;
ints
=
a
.
ints
;
atoms
=
a
.
atoms
;
chars
=
a
.
chars
;
strs
=
a
.
strs
;
}
...
...
@@ -220,6 +231,7 @@ let rec empty_rec d =
else
if
Assumptions
.
mem
d
!
memo
then
true
else
if
not
(
Intervals
.
is_empty
d
.
ints
)
then
false
else
if
not
(
Atoms
.
is_empty
d
.
atoms
)
then
false
else
if
not
(
Chars
.
is_empty
d
.
chars
)
then
false
else
if
not
(
Strings
.
is_empty
d
.
strs
)
then
false
else
(
let
backup
=
!
memo
in
...
...
@@ -298,6 +310,7 @@ let rec find f = function
type
t
=
|
Int
of
int
|
Atom
of
atom
|
Char
of
Chars
.
Unichar
.
t
|
String
of
string
|
Pair
of
t
*
t
|
Record
of
(
label
*
t
)
list
...
...
@@ -311,6 +324,7 @@ let rec sample_rec memo d =
else
try
Int
(
Intervals
.
sample
d
.
ints
)
with
Not_found
->
try
Atom
(
Atoms
.
sample
(
gen_atom
0
)
d
.
atoms
)
with
Not_found
->
try
Char
(
Chars
.
sample
d
.
chars
)
with
Not_found
->
try
String
(
Strings
.
sample
d
.
strs
)
with
Not_found
->
try
sample_rec_arrow
d
.
arrow
with
Not_found
->
...
...
@@ -604,6 +618,7 @@ struct
if
d
=
any
then
Format
.
fprintf
ppf
"Any"
else
print_union
ppf
(
Intervals
.
print
d
.
ints
@
Chars
.
print
d
.
chars
@
Strings
.
print
d
.
strs
@
Atoms
.
print
"AnyAtom"
print_atom
d
.
atoms
@
Boolean
.
print
"(Any,Any)"
print_times
d
.
times
@
...
...
@@ -653,6 +668,7 @@ struct
let
rec
print_sample
ppf
=
function
|
Sample
.
Int
i
->
Format
.
fprintf
ppf
"%i"
i
|
Sample
.
Atom
a
->
Format
.
fprintf
ppf
"`%s"
(
atom_name
a
)
|
Sample
.
Char
c
->
Chars
.
Unichar
.
print
ppf
c
|
Sample
.
String
s
->
Format
.
fprintf
ppf
"%S"
s
|
Sample
.
Pair
(
x1
,
x2
)
->
Format
.
fprintf
ppf
"(%a,%a)"
...
...
types/types.mli
View file @
12c7039b
type
label
=
int
type
atom
=
int
type
const
=
Integer
of
int
|
Atom
of
atom
|
String
of
string
type
const
=
Integer
of
int
|
Atom
of
atom
|
String
of
string
|
Char
of
Chars
.
Unichar
.
t
(** Algebra **)
...
...
@@ -33,6 +33,8 @@ val atom : atom -> descr
val
times
:
node
->
node
->
descr
val
arrow
:
node
->
node
->
descr
val
record
:
label
->
bool
->
node
->
descr
val
char
:
Chars
.
Unichar
.
t
->
descr
val
char_class
:
Chars
.
Unichar
.
t
->
Chars
.
Unichar
.
t
->
descr
val
string
:
Strings
.
Regexp
.
regexp
->
descr
val
constant
:
const
->
descr
...
...
@@ -126,6 +128,7 @@ sig
type
t
=
|
Int
of
int
|
Atom
of
atom
|
Char
of
Chars
.
Unichar
.
t
|
String
of
string
|
Pair
of
t
*
t
|
Record
of
(
label
*
t
)
list
...
...
typing/typer.ml
View file @
12c7039b
...
...
@@ -42,11 +42,11 @@ module StringSet = Set.Make(S)
let
mk'
=
let
counter
=
ref
0
in
fun
()
->
fun
loc
->
incr
counter
;
let
rec
x
=
{
id
=
!
counter
;
loc'
=
no
loc
;
loc'
=
loc
;
fv
=
None
;
descr'
=
`Alias
(
"__dummy__"
,
x
);
type_node
=
None
;
...
...
@@ -55,8 +55,7 @@ let mk' =
x
let
cons
loc
d
=
let
x
=
mk'
()
in
x
.
loc'
<-
loc
;
let
x
=
mk'
loc
in
x
.
descr'
<-
d
;
x
...
...
@@ -158,14 +157,7 @@ let rec compile env { loc = loc; descr = d } : ti =
with
Not_found
->
raise_loc
loc
(
Pattern
(
"Undefined type variable "
^
s
))
)
|
Recurs
(
t
,
b
)
->
let
b
=
List
.
map
(
fun
(
v
,
t
)
->
(
v
,
t
,
mk'
()
))
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
.
loc'
<-
t
.
loc
;
x
.
descr'
<-
`Alias
(
v
,
compile
env
t
))
b
;
compile
env
t
|
Recurs
(
t
,
b
)
->
compile
(
compile_many
env
b
)
t
|
Regexp
(
r
,
q
)
->
compile
env
(
Regexp
.
compile
r
q
)
|
Internal
t
->
cons
loc
(
`Type
t
)
|
Or
(
t1
,
t2
)
->
cons
loc
(
`Or
(
compile
env
t1
,
compile
env
t2
))
...
...
@@ -177,6 +169,14 @@ let rec compile env { loc = loc; descr = d } : ti =
|
Constant
(
x
,
v
)
->
cons
loc
(
`Constant
(
x
,
v
))
|
Capture
x
->
cons
loc
(
`Capture
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
;
env
let
rec
comp_fv
seen
s
=
match
s
.
fv
with
|
Some
l
->
l
...
...
@@ -266,16 +266,24 @@ and pat_node s : Patterns.node =
Patterns
.
define
x
t
;
x
let
typ
e
=
let
e
=
compile
StringMap
.
empty
e
in
let
global_types
=
ref
StringMap
.
empty
let
mk_typ
e
=
if
fv
e
=
[]
then
type_node
e
else
(
raise_loc
e
.
loc'
(
Pattern
"Capture variables are not allowed in types"
))
else
raise_loc
e
.
loc'
(
Pattern
"Capture variables are not allowed in types"
)
let
typ
e
=
mk_typ
(
compile
!
global_types
e
)
let
pat
e
=
let
e
=
compile
StringMap
.
empty
e
in
let
e
=
compile
!
global_types
e
in
pat_node
e
let
register_global_types
b
=
let
env
=
compile_many
!
global_types
b
in
List
.
iter
(
fun
(
v
,_
)
->
ignore
(
mk_typ
(
StringMap
.
find
v
env
)))
b
;
global_types
:=
env
(* II. Build skeleton *)
...
...
typing/typer.mli
View file @
12c7039b
...
...
@@ -4,6 +4,9 @@ exception Constraint of Types.descr * Types.descr * string
val
compile_regexp
:
Ast
.
regexp
->
Ast
.
ppat
->
Ast
.
ppat
val
register_global_types
:
(
string
*
Ast
.
ppat
)
list
->
unit
(* the global environment is untouched if the function fails *)
val
typ
:
Ast
.
ppat
->
Typed
.
ttyp
val
pat
:
Ast
.
ppat
->
Typed
.
tpat
...
...
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