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
bc621788
Commit
bc621788
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-03-14 18:11:21 by cvscast] Empty log message
Original author: cvscast Date: 2003-03-14 18:13:42+00:00
parent
7380aa43
Changes
13
Hide whitespace changes
Inline
Side-by-side
parser/ast.ml
View file @
bc621788
...
...
@@ -41,7 +41,8 @@ and pexpr' =
|
Op
of
string
*
pexpr
list
|
Match
of
pexpr
*
branches
|
Map
of
pexpr
*
branches
|
Dot
of
(
pexpr
*
label
)
|
Dot
of
pexpr
*
label
|
RemoveField
of
pexpr
*
label
(* Exceptions *)
|
Try
of
pexpr
*
branches
...
...
parser/parser.ml
View file @
bc621788
...
...
@@ -123,11 +123,10 @@ EXTEND
]
|
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
]
|
[
e1
=
expr
;
"++"
;
"{"
;
l
=
[
LIDENT
|
UIDENT
];
"="
;
e
=
expr
;
"}"
->
assert
false
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
|
"++"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
|
e
=
expr
;
"--"
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
RemoveField
(
e
,
LabelPool
.
mk
l
))
]
|
[
e1
=
expr
;
op
=
[
"*"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
...
...
runtime/eval.ml
View file @
bc621788
...
...
@@ -75,7 +75,9 @@ let rec eval env e0 =
|
Typed
.
Op
(
"<="
,
[
e1
;
e2
])
->
eval_lte
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
">"
,
[
e1
;
e2
])
->
eval_gt
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
">="
,
[
e1
;
e2
])
->
eval_gte
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"++"
,
[
e1
;
e2
])
->
eval_merge_record
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
Typed
.
RemoveField
(
e
,
l
)
->
eval_remove_field
l
(
eval
env
e
)
|
Typed
.
Op
(
o
,_
)
->
failwith
(
"Unknown operator "
^
o
)
...
...
@@ -120,6 +122,10 @@ and eval_dot l = function
|
Record
r
->
LabelMap
.
assoc
l
r
|
_
->
assert
false
and
eval_remove_field
l
=
function
|
Record
r
->
Record
(
LabelMap
.
remove
l
r
)
|
_
->
assert
false
and
eval_add
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vadd
x
y
)
|
_
->
assert
false
...
...
@@ -195,3 +201,8 @@ and eval_gte v1 v2 =
let
c
=
Value
.
compare
v1
v2
in
Value
.
vbool
(
Value
.
compare
v1
v2
>=
0
)
and
eval_merge_record
v1
v2
=
match
(
v1
,
v2
)
with
|
Record
r1
,
Record
r2
->
Record
(
LabelMap
.
merge
(
fun
x
y
->
y
)
r1
r2
)
|
_
->
assert
false
tests/memento.xml
View file @
bc621788
...
...
@@ -110,6 +110,23 @@ Integer,Integer -> Bool = <duce>`true | `false</duce>
</ul>
</section>
<section>
<title>
Record
</title>
<ul>
<li>
Records litteral
<duce>
{ l1 = e1; ...; ln = en }
</duce></li>
<li>
Types:
<duce>
{| l1 = t1; ...; ln = tn |}
</duce>
(closed, no more
fields allowed),
<duce>
>{ l1 = t1; ...; ln = tn }
</duce>
(open,
any other field allowed). Optional fields:
<duce>
li =? ti
</duce>
instead of
<duce>
li = ti
</duce>
.
</li>
<li>
Record concatenation:
<duce>
e1 ++ e2
</duce>
(priority to the fields from the right argument)
</li>
<li>
Field removal:
<duce>
e1 -- l
</duce>
(does nothing if the
field
<duce>
l
</duce>
is not present)
</li>
<li>
Field access:
<duce>
e1 . l
</duce></li>
<li>
Record:
<duce>
{ l1 = p1; ...; ln = pn }
</duce></li>
</ul>
</section>
<section>
<title>
Strings
</title>
<ul>
...
...
types/normal.ml
View file @
bc621788
...
...
@@ -86,6 +86,9 @@ struct
let
pi1
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
X1
.
cup
accu
t1
)
X1
.
empty
let
pi2
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
X2
.
cup
accu
t2
)
X2
.
empty
let
pi2_restricted
restr
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
if
X1
.
is_empty
(
X1
.
cap
t1
restr
)
then
accu
...
...
types/normal.mli
View file @
bc621788
...
...
@@ -27,5 +27,6 @@ sig
val
boolean
:
(
X1
.
t
*
X2
.
t
)
bool
->
t
val
pi1
:
t
->
X1
.
t
val
pi2
:
t
->
X2
.
t
val
pi2_restricted
:
X1
.
t
->
t
->
X2
.
t
end
types/patterns.ml
View file @
bc621788
...
...
@@ -370,7 +370,6 @@ struct
let
record
=
match
lab
with
|
None
->
(* Should check that r has only empty_cases *)
let
(
x
,
y
)
=
Types
.
Record
.
empty_cases
t
in
RecNolabel
((
if
x
then
Some
empty_res
else
None
)
,
(
if
y
then
Some
empty_res
else
None
))
...
...
types/sortedList.ml
View file @
bc621788
...
...
@@ -64,6 +64,7 @@ sig
val
is_empty
:
(
'
a
,
'
b
)
map
->
bool
val
singleton
:
'
a
elem
->
'
b
->
(
'
a
,
'
b
)
map
val
assoc_remove
:
'
a
elem
->
(
'
a
,
'
b
)
map
->
'
b
*
(
'
a
,
'
b
)
map
val
remove
:
'
a
elem
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
merge
:
(
'
b
->
'
b
->
'
b
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
merge_elem
:
'
b
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
union_disj
:
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
...
...
@@ -254,6 +255,16 @@ module Map = struct
let
l
=
assoc_remove_aux
v
r
l
in
(
!
r
,
l
)
(* TODO: is is faster to raise exception Not_found and return
original list ? *)
let
rec
remove
v
=
function
|
(((
x
,
y
)
as
a
)
::
rem
)
as
l
->
let
c
=
X
.
compare
x
v
in
if
c
=
0
then
rem
else
if
c
<
0
then
a
::
(
remove
v
rem
)
else
l
|
[]
->
[]
let
rec
merge
f
l1
l2
=
match
(
l1
,
l2
)
with
|
((
x1
,
y1
)
as
t1
)
::
q1
,
((
x2
,
y2
)
as
t2
)
::
q2
->
...
...
types/sortedList.mli
View file @
bc621788
...
...
@@ -60,6 +60,7 @@ sig
val
is_empty
:
(
'
a
,
'
b
)
map
->
bool
val
singleton
:
'
a
elem
->
'
b
->
(
'
a
,
'
b
)
map
val
assoc_remove
:
'
a
elem
->
(
'
a
,
'
b
)
map
->
'
b
*
(
'
a
,
'
b
)
map
val
remove
:
'
a
elem
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
merge
:
(
'
b
->
'
b
->
'
b
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
merge_elem
:
'
b
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
union_disj
:
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
...
...
types/types.ml
View file @
bc621788
...
...
@@ -1212,9 +1212,9 @@ struct
if
o
&&
LabelMap
.
is_empty
l
then
any_record
else
{
empty
with
record
=
BoolRec
.
atom
(
o
,
l
)
}
type
zor
=
Pair
of
descr
*
descr
|
Any
|
Empty
type
zor
=
Pair
of
descr
*
descr
|
Any
let
aux
d
l
=
let
aux
_split
d
l
=
let
f
(
o
,
r
)
=
try
let
(
lt
,
rem
)
=
LabelMap
.
assoc_remove
l
r
in
...
...
@@ -1223,7 +1223,9 @@ struct
if
o
then
if
LabelMap
.
is_empty
r
then
Any
else
Pair
(
any_or_absent
,
{
empty
with
record
=
BoolRec
.
atom
(
o
,
r
)
})
else
Empty
else
Pair
({
empty
with
absent
=
true
}
,
{
empty
with
record
=
BoolRec
.
atom
(
o
,
r
)
})
in
List
.
fold_left
(
fun
b
(
p
,
n
)
->
...
...
@@ -1231,14 +1233,12 @@ struct
|
x
::
p
->
(
match
f
x
with
|
Pair
(
t1
,
t2
)
->
aux_p
((
t1
,
t2
)
::
accu
)
p
|
Any
->
aux_p
accu
p
|
Empty
->
b
)
|
Any
->
aux_p
accu
p
)
|
[]
->
aux_n
accu
[]
n
and
aux_n
p
accu
=
function
|
x
::
n
->
(
match
f
x
with
|
Pair
(
t1
,
t2
)
->
aux_n
p
((
t1
,
t2
)
::
accu
)
n
|
Empty
->
aux_n
p
accu
n
|
Any
->
b
)
|
[]
->
(
p
,
accu
)
::
b
in
aux_p
[]
p
)
...
...
@@ -1246,10 +1246,10 @@ struct
(
BoolRec
.
get
d
.
record
)
let
split
(
d
:
descr
)
l
=
TR
.
boolean
(
aux
d
l
)
TR
.
boolean
(
aux
_split
d
l
)
let
split_normal
d
l
=
TR
.
boolean_normal
(
aux
d
l
)
TR
.
boolean_normal
(
aux
_split
d
l
)
let
project
d
l
=
...
...
@@ -1257,6 +1257,9 @@ struct
if
t
.
absent
then
raise
Not_found
;
t
let
remove_field
d
l
=
TR
.
pi2
(
split
d
l
)
let
first_label
d
=
let
min
=
ref
LabelPool
.
dummy_max
in
let
aux
(
_
,
r
)
=
...
...
@@ -1277,6 +1280,38 @@ struct
(
x
land
2
<>
0
,
x
land
1
<>
0
)
(*TODO: optimize merge
- pre-compute the sequence of labels
- remove empty or full { l = t }
*)
let
merge
d1
d2
=
let
res
=
ref
empty
in
let
rec
aux
accu
d1
d2
=
let
l
=
min
(
first_label
d1
)
(
first_label
d2
)
in
if
l
=
LabelPool
.
dummy_max
then
let
(
some1
,
none1
)
=
empty_cases
d1
and
(
some2
,
none2
)
=
empty_cases
d2
in
let
none
=
none1
&&
none2
and
some
=
some1
||
some2
in
let
accu
=
LabelMap
.
from_list
(
fun
_
_
->
assert
false
)
accu
in
(* approx for the case (some && not none) ... *)
res
:=
cup
!
res
(
record'
(
some
,
accu
))
else
let
l1
=
split
d1
l
and
l2
=
split
d2
l
in
let
loop
(
t1
,
d1
)
(
t2
,
d2
)
=
let
t
=
if
t2
.
absent
then
cup
t1
{
t2
with
absent
=
false
}
else
t2
in
aux
((
l
,
cons
t
)
::
accu
)
d1
d2
in
List
.
iter
(
fun
x
->
List
.
iter
(
loop
x
)
l2
)
l1
in
aux
[]
d1
d2
;
!
res
let
any
=
{
empty
with
record
=
any
.
record
}
end
...
...
types/types.mli
View file @
bc621788
...
...
@@ -112,50 +112,8 @@ module Record : sig
val
empty_cases
:
descr
->
bool
*
bool
(*
val restrict_field : t -> label -> descr -> t
val restrict_label_absent: t -> label -> t
val restrict_label_present: t -> label -> t
val label_present: t -> label -> (descr * t) list
val somefield_possible: t -> bool
val nofield_possible: t -> bool
val any : descr
val project_field: t -> label -> descr
val project : descr -> label -> descr
(*
(* List of maps label -> (optional, content) *)
type t (* = (label, (bool * descr)) SortedMap.t list *)
val get: descr -> t
val descr: t -> descr
val is_empty: t -> bool
val restrict_label_present: t -> label -> t
val restrict_field: t -> label -> descr -> t
val restrict_label_absent: t -> label -> t
val project_field: t -> label -> descr
*)
type normal =
[ `Success (* { } *)
| `Fail (* Empty *)
| `NoField (* {| |} *)
| `SomeField (* { } \ {| |} *)
| `Label of label * (descr * normal) list * normal ]
val normal: descr -> normal
val normal': t -> label -> (descr * t) list * t
val first_label: t -> [ `Success|`Fail|`NoField|`SomeField|`Label of label ]
val change_field: t -> label -> node -> t
(*
val project : descr -> label -> descr
(* Raise Not_found if label is not necessarily present *)
*)
*)
val
merge
:
descr
->
descr
->
descr
val
remove_field
:
descr
->
label
->
descr
end
module
Arrow
:
sig
...
...
typing/typed.ml
View file @
bc621788
...
...
@@ -36,6 +36,7 @@ and texpr' =
|
Op
of
string
*
texpr
list
|
Match
of
texpr
*
branches
|
Map
of
texpr
*
branches
|
RemoveField
of
texpr
*
label
|
Dot
of
texpr
*
label
(* Exception *)
...
...
typing/typer.ml
View file @
bc621788
...
...
@@ -489,6 +489,9 @@ let rec expr loc' glb { loc = loc; descr = d } =
|
Dot
(
e
,
l
)
->
let
(
fv
,
e
)
=
expr
loc
glb
e
in
(
fv
,
Typed
.
Dot
(
e
,
l
))
|
RemoveField
(
e
,
l
)
->
let
(
fv
,
e
)
=
expr
loc
glb
e
in
(
fv
,
Typed
.
RemoveField
(
e
,
l
))
|
RecordLitt
r
->
let
fv
=
ref
Fv
.
empty
in
let
r
=
LabelMap
.
map
...
...
@@ -771,6 +774,9 @@ and compute_type' loc env = function
let
t
=
type_check
env
e
Types
.
Record
.
any
true
in
(
try
(
Types
.
Record
.
project
t
l
)
with
Not_found
->
raise_loc
loc
(
WrongLabel
(
t
,
l
)))
|
RemoveField
(
e
,
l
)
->
let
t
=
type_check
env
e
Types
.
Record
.
any
true
in
Types
.
Record
.
remove_field
t
l
|
Op
(
op
,
el
)
->
let
args
=
List
.
map
(
fun
e
->
(
e
.
exp_loc
,
compute_type
env
e
))
el
in
type_op
loc
op
args
...
...
@@ -907,6 +913,12 @@ and type_op loc op args =
|
(
"<="
|
"<"
|
">"
|
">="
)
,
[
loc1
,
t1
;
loc2
,
t2
]
->
(* could prevent comparision of functional value here... *)
Builtin
.
bool
|
"++"
,
[
loc1
,
t1
;
loc2
,
t2
]
->
check
loc1
t1
Types
.
Record
.
any
"The left argument of ++ must be a record"
;
check
loc2
t2
Types
.
Record
.
any
"The right argument of ++ must be a record"
;
Types
.
Record
.
merge
t1
t2
|
_
->
assert
false
and
type_int_binop
f
loc1
t1
loc2
t2
=
...
...
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