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
1a2a6a78
Commit
1a2a6a78
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-10-26 20:45:22 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-26 20:45:22+00:00
parent
a389fd6b
Changes
13
Hide whitespace changes
Inline
Side-by-side
depend
View file @
1a2a6a78
...
...
@@ -3,14 +3,16 @@ 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 types/atoms.cmi types/chars.cmi \
parser/lexer.cmo parser/location.cmi
types/sequence.cmi types/types.cmi
\
parser/parser.cmi
types/intervals.cmi
parser/lexer.cmo parser/location.cmi \
types/sequence.cmi types/types.cmi
parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
parser/lexer.cmx parser/location.cmx
types/sequence.cmx types/types.cmx
\
parser/parser.cmi
types/intervals.cmx
parser/lexer.cmx parser/location.cmx \
types/sequence.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
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/intervals.cmi parser/location.cmi \
types/patterns.cmi types/sequence.cmi types/sortedList.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi
...
...
@@ -59,12 +61,14 @@ 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 \
types/sortedMap.cmi
runtime/value.cmi: types/
char
s.cmi typing/typed.cmo
types/types.cmi
runtime/value.cmo: types/chars.cmi typ
ing/typed
.cm
o
types/
types
.cmi \
runtime/value.cmi
runtime/value.cmx: types/chars.cmx typ
ing/typed
.cmx types/
types
.cmx \
runtime/value.cmi
runtime/value.cmi: types/
pattern
s.cmi typing/typed.cmo
runtime/value.cmo: types/chars.cmi typ
es/patterns
.cm
i
types/
sequence
.cmi \
types/sortedMap.cmi typing/typed.cmo types/types.cmi
runtime/value.cmi
runtime/value.cmx: types/chars.cmx typ
es/patterns
.cmx types/
sequence
.cmx \
types/sortedMap.cmx typing/typed.cmx types/types.cmx
runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo parser/location.cmi \
parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi
parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx parser/location.cmx \
parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx
parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx
driver/cduce.ml
View file @
1a2a6a78
...
...
@@ -100,7 +100,7 @@ let phrase ph =
let
t
=
Typer
.
type_check
Typer
.
Env
.
empty
e
Types
.
any
true
in
Format
.
fprintf
ppf
"|- %a@
\n
"
print_norm
t
;
let
v
=
Value
.
eval
Value
.
empty_env
e
in
Format
.
fprintf
ppf
"=>
%a
@
\n
"
Value
.
print
v
Format
.
fprintf
ppf
"=>
@[%a@]
@
\n
"
Value
.
print
v
|
Ast
.
TypeDecl
_
->
()
|
Ast
.
Debug
l
->
debug
l
|
_
->
assert
false
...
...
parser/parser.ml
View file @
1a2a6a78
...
...
@@ -67,10 +67,6 @@ EXTEND
mk
loc
(
Match
(
e1
,
[
p
,
e2
]))
]
|
[
LIDENT
"flatten"
;
e
=
expr
->
mk
loc
(
Op
(
"flatten"
,
[
e
]))
|
e1
=
expr
;
e2
=
expr
->
mk
loc
(
Apply
(
e1
,
e2
))
]
|
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
...
...
@@ -82,6 +78,11 @@ EXTEND
[
e
=
expr
;
"."
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
Dot
(
e
,
Types
.
label
l
))
]
|
[
LIDENT
"flatten"
;
e
=
expr
->
mk
loc
(
Op
(
"flatten"
,
[
e
]))
|
e1
=
expr
;
e2
=
expr
->
mk
loc
(
Apply
(
e1
,
e2
))
]
|
"no_appl"
[
c
=
const
->
mk
loc
(
Cst
c
)
|
"("
;
l
=
LIST1
expr
SEP
","
;
")"
->
tuple
loc
l
...
...
@@ -185,7 +186,16 @@ EXTEND
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
Big_int
.
big_int_of_string
i
and
j
=
Big_int
.
big_int_of_string
j
in
mk
loc
(
Internal
(
Types
.
interval
i
j
))
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
bounded
i
j
)))
|
i
=
INT
->
let
i
=
Big_int
.
big_int_of_string
i
in
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
atom
i
)))
|
"*--"
;
j
=
INT
->
let
j
=
Big_int
.
big_int_of_string
j
in
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
left
j
)))
|
i
=
INT
;
"--*"
->
let
i
=
Big_int
.
big_int_of_string
i
in
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
right
i
)))
|
i
=
char
->
mk
loc
(
Internal
(
Types
.
char
(
Chars
.
char_class
i
i
)))
|
i
=
char
;
"--"
;
j
=
char
->
...
...
runtime/value.ml
View file @
1a2a6a78
...
...
@@ -15,24 +15,60 @@ and abstr = {
fun_body
:
Typed
.
branches
;
}
let
rec
print
ppf
=
function
|
Pair
(
x
,
y
)
->
Format
.
fprintf
ppf
"(%a,%a)"
print
x
print
y
|
Record
l
->
Format
.
fprintf
ppf
"{%a}"
print_record
l
|
Atom
a
->
Format
.
fprintf
ppf
"`%s"
(
Types
.
atom_name
a
)
|
Integer
i
->
Format
.
fprintf
ppf
"%s"
(
Big_int
.
string_of_big_int
i
)
|
Char
c
->
Chars
.
Unichar
.
print
ppf
c
|
Fun
c
->
Format
.
fprintf
ppf
"<fun>"
let
rec
is_seq
=
function
|
Pair
(
_
,
y
)
when
is_seq
y
->
true
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
true
|
_
->
false
let
is_xml
=
function
|
Pair
(
Atom
_
,
Pair
(
Record
_
,
s
))
when
is_seq
s
->
true
|
_
->
false
let
rec
is_str
=
function
|
Pair
(
Char
_
,
y
)
when
is_str
y
->
true
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
true
|
_
->
false
let
rec
print
ppf
v
=
if
is_str
v
then
Format
.
fprintf
ppf
"
\"
%a
\"
"
print_quoted_str
v
else
if
is_xml
v
then
print_xml
ppf
v
else
if
is_seq
v
then
Format
.
fprintf
ppf
"[ %a]"
print_seq
v
else
match
v
with
|
Pair
(
x
,
y
)
->
Format
.
fprintf
ppf
"(%a,%a)"
print
x
print
y
|
Record
l
->
Format
.
fprintf
ppf
"{%a }"
print_record
l
|
Atom
a
->
Format
.
fprintf
ppf
"`%s"
(
Types
.
atom_name
a
)
|
Integer
i
->
Format
.
fprintf
ppf
"%s"
(
Big_int
.
string_of_big_int
i
)
|
Char
c
->
Chars
.
Unichar
.
print
ppf
c
|
Fun
c
->
Format
.
fprintf
ppf
"<fun>"
and
print_quoted_str
ppf
=
function
|
Pair
(
Char
c
,
y
)
->
Chars
.
Unichar
.
print_in_string
ppf
c
;
print_quoted_str
ppf
y
|
_
->
()
and
print_seq
ppf
=
function
|
Pair
(
Char
_
,
_
)
as
s
->
Format
.
fprintf
ppf
"'%a"
print_str
s
|
Pair
(
x
,
y
)
->
Format
.
fprintf
ppf
"@[%a@]@ %a"
print
x
print_seq
y
|
_
->
()
and
print_str
ppf
=
function
|
Pair
(
Char
c
,
y
)
->
Chars
.
Unichar
.
print_in_string
ppf
c
;
print_str
ppf
y
|
v
->
Format
.
fprintf
ppf
"
\'
"
;
print_seq
ppf
v
and
print_xml
ppf
=
function
|
Pair
(
Atom
tag
,
Pair
(
Record
attr
,
content
))
->
Format
.
fprintf
ppf
"@[<hv2><%s%a>[@ %a@]]"
(
Types
.
atom_name
tag
)
print_record
attr
print_seq
content
|
_
->
assert
false
and
print_record
ppf
=
function
|
[]
->
()
|
[
f
]
->
print_field
ppf
f
|
f
::
rem
->
Format
.
fprintf
ppf
"%a;
%a"
print_field
f
print_record
rem
|
[
f
]
->
Format
.
fprintf
ppf
" %a"
print_field
f
|
f
::
rem
->
Format
.
fprintf
ppf
"
%a;%a"
print_field
f
print_record
rem
and
print_field
ppf
(
l
,
v
)
=
Format
.
fprintf
ppf
"%s = %a"
(
Types
.
label_name
l
)
print
v
...
...
@@ -144,11 +180,10 @@ and run_disp_field v bindings fields l vl = function
(* Evaluation of expressions *)
let
rec
eval
env
e
=
match
e
.
Typed
.
exp_descr
with
let
rec
eval
env
e
0
=
match
e
0
.
Typed
.
exp_descr
with
|
Typed
.
Var
s
->
Env
.
find
s
env
|
Typed
.
Apply
(
f
,
arg
)
->
eval_apply
(
eval
env
f
)
(
eval
env
arg
)
|
Typed
.
Apply
(
f
,
arg
)
->
eval_apply
(
eval
env
f
)
(
eval
env
arg
)
|
Typed
.
Abstraction
a
->
let
a'
=
{
fun_env
=
env
;
...
...
@@ -160,8 +195,7 @@ let rec eval env e =
|
Some
f
->
a'
.
fun_env
<-
Env
.
add
f
self
a'
.
fun_env
|
None
->
()
);
self
|
Typed
.
RecordLitt
r
->
Record
(
List
.
map
(
fun
(
l
,
e
)
->
(
l
,
eval
env
e
))
r
)
|
Typed
.
RecordLitt
r
->
Record
(
List
.
map
(
fun
(
l
,
e
)
->
(
l
,
eval
env
e
))
r
)
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Cst
c
->
const
c
|
Typed
.
Match
(
arg
,
brs
)
->
eval_branches
env
brs
(
eval
env
arg
)
...
...
tests/addrbook.cd
View file @
1a2a6a78
...
...
@@ -4,7 +4,7 @@ type Name = <name>[String];;
type Addr = <addr>[String];;
type Tel = <tel>[String];;
(*
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
...
...
@@ -41,7 +41,7 @@ type Tel = <tel>[String];;
<name>["Peter Buneman"]
<addr>["Scotland"]
];;
*)
(*
...
...
types/boolean.ml
View file @
1a2a6a78
...
...
@@ -19,6 +19,19 @@ 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
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
in
List
.
rev
(
aux
[]
t
)
let
rec
fold2_aux
f
a
x
=
function
|
[]
->
x
|
h
::
t
->
fold2_aux
f
a
(
f
x
a
h
)
t
...
...
@@ -45,7 +58,7 @@ let cap s t =
lines1
lines2
in
SortedList
.
cup
common
(
SortedList
.
from_list
lines
)
clean
(
SortedList
.
cup
common
(
SortedList
.
from_list
lines
)
)
let
diff
c1
c2
=
if
c2
==
full
then
empty
...
...
types/chars.ml
View file @
1a2a6a78
...
...
@@ -17,6 +17,9 @@ module Unichar = struct
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
type
t
=
(
Unichar
.
t
*
Unichar
.
t
)
list
...
...
types/chars.mli
View file @
1a2a6a78
...
...
@@ -5,6 +5,7 @@ module Unichar : sig
val
to_int
:
t
->
int
val
print
:
Format
.
formatter
->
t
->
unit
val
print_in_string
:
Format
.
formatter
->
t
->
unit
end
type
t
=
(
Unichar
.
t
*
Unichar
.
t
)
list
...
...
types/intervals.ml
View file @
1a2a6a78
...
...
@@ -38,9 +38,13 @@ let hash = function
let
empty
=
[]
let
any
=
[
Any
]
let
atom
a
b
=
let
bounded
a
b
=
if
le_big_int
a
b
then
[
Bounded
(
a
,
b
)]
else
empty
let
left
a
=
[
Left
a
]
let
right
a
=
[
Right
a
]
let
atom
a
=
bounded
a
a
let
rec
iadd_left
l
b
=
match
l
with
|
[]
->
[
Left
b
]
...
...
types/intervals.mli
View file @
1a2a6a78
...
...
@@ -9,7 +9,10 @@ val cup : t -> t -> t
val
cap
:
t
->
t
->
t
val
diff
:
t
->
t
->
t
val
atom
:
Big_int
.
big_int
->
Big_int
.
big_int
->
t
val
bounded
:
Big_int
.
big_int
->
Big_int
.
big_int
->
t
val
left
:
Big_int
.
big_int
->
t
val
right
:
Big_int
.
big_int
->
t
val
atom
:
Big_int
.
big_int
->
t
val
is_empty
:
t
->
bool
...
...
types/patterns.ml
View file @
1a2a6a78
...
...
@@ -451,6 +451,7 @@ struct
let
p
=
pl
.
(
i
)
in
let
tp
=
p
.
Normal
.
na
in
let
v
=
p
.
Normal
.
nfv
in
(* let tp = Types.normalize tp in *)
`Switch
(
num
arity
v
,
aux
(
Types
.
cap
t
tp
)
(
arity
+
(
List
.
length
v
))
(
i
+
1
)
,
...
...
@@ -565,6 +566,7 @@ struct
)
yes
;
unselect
.
(
i
)
<-
no
@
unselect
.
(
i
)
in
Array
.
iteri
(
fun
i
->
List
.
iter
(
aux
i
))
pl
;
let
sorted
=
Array
.
of_list
(
SortedMap
.
from_list
SortedList
.
cup
!
accu
)
in
let
infos
=
Array
.
map
snd
sorted
in
let
disp
=
dispatcher
t
(
Array
.
map
fst
sorted
)
in
...
...
@@ -574,6 +576,7 @@ struct
List
.
iter
(
fun
(
j
,
r
)
->
List
.
iter
(
add
r
)
infos
.
(
j
))
m
;
d
t
selected
unselect
in
let
res
=
Array
.
map
result
disp
.
codes
in
post
(
disp
,
res
)
...
...
@@ -585,7 +588,7 @@ struct
let
t
=
Types
.
diff
t
(
p
.
Normal
.
a
)
in
(
t
,
(
p
,
e
)
::
brs
)
)
(
t
,
[]
)
brs
in
let
pl
=
Array
.
map
(
fun
x
->
[
x
])
(
Array
.
of_list
brs
)
in
get_tests
pl
...
...
types/types.ml
View file @
1a2a6a78
...
...
@@ -36,14 +36,14 @@ module I = struct
chars
=
Chars
.
any
;
}
let
interval
i
j
=
{
empty
with
ints
=
Intervals
.
atom
i
j
}
let
interval
i
=
{
empty
with
ints
=
i
}
let
times
x
y
=
{
empty
with
times
=
Boolean
.
atom
(
x
,
y
)
}
let
arrow
x
y
=
{
empty
with
arrow
=
Boolean
.
atom
(
x
,
y
)
}
let
record
label
opt
t
=
{
empty
with
record
=
Boolean
.
atom
(
label
,
opt
,
t
)
}
let
atom
a
=
{
empty
with
atoms
=
a
}
let
char
c
=
{
empty
with
chars
=
c
}
let
constant
=
function
|
Integer
i
->
interval
i
i
|
Integer
i
->
interval
(
Intervals
.
atom
i
)
|
Atom
a
->
atom
(
Atoms
.
atom
a
)
|
Char
c
->
char
(
Chars
.
atom
c
)
...
...
types/types.mli
View file @
1a2a6a78
...
...
@@ -33,7 +33,7 @@ val any : descr
(** Constructors **)
val
interval
:
Big_int
.
big_int
->
Big_int
.
big_in
t
->
descr
val
interval
:
Intervals
.
t
->
descr
val
atom
:
atom
Atoms
.
t
->
descr
val
times
:
node
->
node
->
descr
val
arrow
:
node
->
node
->
descr
...
...
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