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
a389fd6b
Commit
a389fd6b
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-10-26 18:42:59 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-26 18:43:00+00:00
parent
e0e5f79d
Changes
5
Show whitespace changes
Inline
Side-by-side
parser/parser.ml
View file @
a389fd6b
...
...
@@ -73,12 +73,14 @@ EXTEND
]
|
[
e1
=
expr
;
"+"
;
e2
=
expr
->
mk
loc
(
Op
(
"+"
,
[
e1
;
e2
]))
|
e1
=
expr
;
"@"
;
e2
=
expr
->
mk
loc
(
Op
(
"@"
,
[
e1
;
e2
]))
]
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
]
;
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
]
|
[
e1
=
expr
;
"*"
;
e2
=
expr
->
mk
loc
(
Op
(
"*"
,
[
e1
;
e2
]))
]
[
e1
=
expr
;
op
=
[
"*"
|
"/"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
]
|
[
e
=
expr
;
"."
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
Dot
(
e
,
Types
.
label
l
))
]
[
e
=
expr
;
"."
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
Dot
(
e
,
Types
.
label
l
))
]
|
"no_appl"
[
c
=
const
->
mk
loc
(
Cst
c
)
...
...
runtime/value.ml
View file @
a389fd6b
...
...
@@ -148,11 +148,7 @@ let rec eval env e =
match
e
.
Typed
.
exp_descr
with
|
Typed
.
Var
s
->
Env
.
find
s
env
|
Typed
.
Apply
(
f
,
arg
)
->
let
f
=
eval
env
f
and
arg
=
eval
env
arg
in
(
match
f
with
|
Fun
a
->
eval_branches
a
.
fun_env
a
.
fun_body
arg
|
_
->
failwith
"application with a non-functional value !"
)
eval_apply
(
eval
env
f
)
(
eval
env
arg
)
|
Typed
.
Abstraction
a
->
let
a'
=
{
fun_env
=
env
;
...
...
@@ -169,6 +165,20 @@ let rec eval env e =
|
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
)
|
Typed
.
Map
(
arg
,
brs
)
->
eval_map
env
brs
(
eval
env
arg
)
|
Typed
.
Op
(
"flatten"
,
[
e
])
->
eval_flatten
(
eval
env
e
)
|
Typed
.
Op
(
"@"
,
[
e1
;
e2
])
->
eval_concat
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"+"
,
[
e1
;
e2
])
->
eval_add
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"*"
,
[
e1
;
e2
])
->
eval_mul
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"-"
,
[
e1
;
e2
])
->
eval_sub
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"/"
,
[
e1
;
e2
])
->
eval_div
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
Typed
.
DebugTyper
t
->
failwith
"Evaluating a ! expression"
|
_
->
failwith
"Unknown expression"
and
eval_apply
f
arg
=
match
f
with
|
Fun
a
->
eval_branches
a
.
fun_env
a
.
fun_body
arg
|
_
->
assert
false
and
eval_branches
env
brs
arg
=
...
...
@@ -179,4 +189,35 @@ and eval_branches env brs arg =
List
.
fold_left
(
fun
env
(
x
,
i
)
->
Env
.
add
x
bindings
.
(
i
)
env
)
env
bind
in
eval
env
e
and
eval_map
env
brs
=
function
|
Pair
(
x
,
y
)
->
Pair
(
eval_branches
env
brs
x
,
eval_map
env
brs
y
)
|
q
->
q
and
eval_flatten
=
function
|
Pair
(
x
,
y
)
->
eval_concat
x
(
eval_flatten
y
)
|
q
->
q
and
eval_concat
l1
l2
=
match
l1
with
|
Pair
(
x
,
y
)
->
Pair
(
x
,
eval_concat
y
l2
)
|
q
->
l2
and
eval_dot
l
=
function
|
Record
r
->
List
.
assoc
l
r
|
_
->
assert
false
and
eval_add
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
add_big_int
x
y
)
|
_
->
assert
false
and
eval_mul
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
mult_big_int
x
y
)
|
_
->
assert
false
and
eval_sub
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
sub_big_int
x
y
)
|
_
->
assert
false
and
eval_div
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
div_big_int
x
y
)
|
_
->
assert
false
types/intervals.ml
View file @
a389fd6b
...
...
@@ -172,3 +172,15 @@ let add l1 l2 =
accu
l2
)
empty
l1
let
negat
=
List
.
rev_map
(
function
|
Bounded
(
i
,
j
)
->
Bounded
(
minus_big_int
j
,
minus_big_int
i
)
|
Left
i
->
Right
(
minus_big_int
i
)
|
Right
j
->
Left
(
minus_big_int
j
)
|
Any
->
Any
)
let
sub
l1
l2
=
add
l1
(
negat
l2
)
types/intervals.mli
View file @
a389fd6b
...
...
@@ -22,3 +22,5 @@ val print : t -> (Format.formatter -> unit) list
val
add
:
t
->
t
->
t
val
sub
:
t
->
t
->
t
val
negat
:
t
->
t
typing/typer.ml
View file @
a389fd6b
...
...
@@ -612,15 +612,17 @@ and branches_aux loc env targ tres constr precise = function
and
type_op
loc
op
args
=
match
(
op
,
args
)
with
|
(
"+"
,
[
loc1
,
t1
;
loc2
,
t2
]
)
->
|
"+"
,
[
loc1
,
t1
;
loc2
,
t2
]
->
type_int_binop
Intervals
.
add
loc1
t1
loc2
t2
|
(
"*"
,
[
loc1
,
t1
;
loc2
,
t2
])
->
|
"-"
,
[
loc1
,
t1
;
loc2
,
t2
]
->
type_int_binop
Intervals
.
sub
loc1
t1
loc2
t2
|
(
"*"
|
"/"
)
,
[
loc1
,
t1
;
loc2
,
t2
]
->
type_int_binop
(
fun
i1
i2
->
Intervals
.
any
)
loc1
t1
loc2
t2
|
(
"@"
,
[
loc1
,
t1
;
loc2
,
t2
]
)
->
|
"@"
,
[
loc1
,
t1
;
loc2
,
t2
]
->
check
loc1
t1
Sequence
.
any
"The first argument of @ must be a sequence"
;
Sequence
.
concat
t1
t2
|
(
"flatten"
,
[
loc1
,
t1
]
)
->
|
"flatten"
,
[
loc1
,
t1
]
->
check
loc1
t1
Sequence
.
seqseq
"The argument of flatten must be a sequence of sequences"
;
Sequence
.
flatten
t1
...
...
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