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
a845c226
Commit
a845c226
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-03-15 08:40:32 by cvscast] Empty log message
Original author: cvscast Date: 2003-03-15 08:40:32+00:00
parent
227c58cc
Changes
5
Hide whitespace changes
Inline
Side-by-side
parser/parser.ml
View file @
a845c226
...
...
@@ -123,9 +123,9 @@ EXTEND
]
|
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
|
"++"
];
e2
=
expr
->
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
|
e
=
expr
;
"
--
"
;
l
=
[
LIDENT
|
UIDENT
]
->
|
e
=
expr
;
"
\\
"
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
RemoveField
(
e
,
LabelPool
.
mk
l
))
]
|
...
...
runtime/eval.ml
View file @
a845c226
...
...
@@ -75,7 +75,6 @@ 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
)
...
...
@@ -128,6 +127,7 @@ and eval_remove_field l = function
and
eval_add
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vadd
x
y
)
|
Record
r1
,
Record
r2
->
Record
(
LabelMap
.
merge
(
fun
x
y
->
y
)
r1
r2
)
|
_
->
assert
false
and
eval_mul
x
y
=
match
(
x
,
y
)
with
...
...
@@ -200,9 +200,3 @@ and eval_gt v1 v2 =
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
types/types.ml
View file @
a845c226
...
...
@@ -1260,6 +1260,16 @@ struct
if
t
.
absent
then
raise
Not_found
;
t
let
project_opt
d
l
=
let
t
=
TR
.
pi1
(
split
d
l
)
in
{
t
with
absent
=
false
}
let
condition
d
l
t
=
TR
.
pi2_restricted
t
(
split
d
l
)
(* TODO: eliminate this cap ... (reord l only_absent_node) when
not necessary. eg. {| ..... |} \ l *)
let
remove_field
d
l
=
cap
(
TR
.
pi2
(
split
d
l
))
(
record
l
only_absent_node
)
...
...
@@ -1281,6 +1291,17 @@ struct
)
d
.
record
in
(
x
land
2
<>
0
,
x
land
1
<>
0
)
let
has_empty_record
d
=
BoolRec
.
compute
~
empty
:
false
~
full
:
true
~
cup
:
(
||
)
~
cap
:
(
&&
)
~
diff
:
(
fun
a
b
->
a
&&
not
b
)
~
atom
:
(
function
(
o
,
r
)
->
List
.
for_all
(
fun
(
l
,
t
)
->
(
descr
t
)
.
absent
)
(
LabelMap
.
get
r
)
)
d
.
record
(*TODO: optimize merge
...
...
types/types.mli
View file @
a845c226
...
...
@@ -108,6 +108,12 @@ module Record : sig
val
project
:
descr
->
label
->
descr
(* Raise Not_found if label is not necessarily present *)
val
condition
:
descr
->
label
->
descr
->
descr
(* condition t1 l t2 : What must follow if field l hash type t2 *)
val
project_opt
:
descr
->
label
->
descr
val
has_empty_record
:
descr
->
bool
val
first_label
:
descr
->
label
val
empty_cases
:
descr
->
bool
*
bool
...
...
typing/typer.ml
View file @
a845c226
...
...
@@ -556,6 +556,9 @@ let let_decl glb p e =
(* III. Type-checks *)
let
int_cup_record
=
Types
.
cup
Types
.
Int
.
any
Types
.
Record
.
any
type
env
=
Types
.
descr
Env
.
t
open
Typed
...
...
@@ -613,22 +616,15 @@ and type_check' loc env e constr precise = match e with
|
Xml
(
e1
,
e2
)
->
type_check_pair
~
kind
:
`XML
loc
env
e1
e2
constr
precise
(*
|
RecordLitt
r
->
let rconstr = Types.Record.get constr in
if Types.Record.is_empty rconstr then
if
not
(
Types
.
Record
.
has_record
constr
)
then
raise_loc
loc
(
ShouldHave
(
constr
,
"but it is a record."
));
(* Completely buggy ! Need to check at the end that all required labels
are present ...A better to do it without precise = true ? *)
let precise = true in
let
(
rconstr
,
res
)
=
List.fold_left
List
.
fold_left
(
fun
(
rconstr
,
res
)
(
l
,
e
)
->
let rconstr = Types.Record.restrict_label_present rconstr l in
let pi = Types.Record.project_
field
rconstr l in
if Types.
Record.
is_empty
rconstr
then
(* could compute (split l e) once... *)
let
pi
=
Types
.
Record
.
project_
opt
rconstr
l
in
if
Types
.
is_empty
pi
then
raise_loc
loc
(
ShouldHave
(
constr
,
(
Printf
.
sprintf
"Field %s is not allowed here."
...
...
@@ -636,19 +632,17 @@ and type_check' loc env e constr precise = match e with
)
));
let
t
=
type_check
env
e
pi
true
in
let rconstr = Types.Record.restrict_field rconstr l t in
let res =
if precise
then Types.cap res (Types.record l false (Types.cons t))
else res in
let
rconstr
=
Types
.
Record
.
condition
rconstr
l
t
in
let
res
=
if
precise
then
(
l
,
Types
.
cons
t
)
::
res
else
res
in
(
rconstr
,
res
)
) (
r
constr,
if precise then Types.Record.any else constr) r
)
(
constr
,
[]
)
(
LabelMap
.
get
r
)
in
(* check loc res constr ""; *)
res
*)
if
not
(
Types
.
Record
.
has_empty_record
rconstr
)
then
raise_loc
loc
(
ShouldHave
(
constr
,
"More field should be present"
));
if
precise
then
Types
.
record'
(
false
,
LabelMap
.
from_list
(
fun
_
_
->
assert
false
)
res
)
else
constr
|
Map
(
e
,
b
)
->
let
t
=
type_check
env
e
(
Sequence
.
star
b
.
br_accept
)
true
in
...
...
@@ -859,7 +853,33 @@ and type_rec_funs env l =
and
type_op
loc
op
args
=
match
(
op
,
args
)
with
|
"+"
,
[
loc1
,
t1
;
loc2
,
t2
]
->
type_int_binop
Intervals
.
add
loc1
t1
loc2
t2
check
loc1
t1
int_cup_record
"The first argument of + must be an integer or a record"
;
let
int
=
Types
.
Int
.
get
t1
in
let
int
=
if
Intervals
.
is_empty
int
then
None
else
Some
int
in
let
r
=
if
Types
.
Record
.
has_record
t1
then
Some
t1
else
None
in
(
match
(
int
,
r
)
with
|
Some
t1
,
None
->
if
not
(
Types
.
Int
.
is_int
t2
)
then
raise_loc
loc2
(
Constraint
(
t2
,
Types
.
Int
.
any
,
"The second argument of + must be an integer"
));
Types
.
Int
.
put
(
Intervals
.
add
t1
(
Types
.
Int
.
get
t2
));
|
None
,
Some
r1
->
check
loc2
t2
Types
.
Record
.
any
"The second argument of + must be a record"
;
Types
.
Record
.
merge
r1
t2
|
None
,
None
->
Types
.
empty
|
Some
t1
,
Some
r1
->
check
loc2
t2
int_cup_record
"The second argument of + must be an integer or a record"
;
Types
.
cup
(
Types
.
Int
.
put
(
Intervals
.
add
t1
(
Types
.
Int
.
get
t2
)))
(
Types
.
Record
.
merge
r1
t2
)
)
|
"-"
,
[
loc1
,
t1
;
loc2
,
t2
]
->
type_int_binop
Intervals
.
sub
loc1
t1
loc2
t2
|
(
"*"
|
"/"
|
"mod"
)
,
[
loc1
,
t1
;
loc2
,
t2
]
->
...
...
@@ -913,12 +933,6 @@ 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