Commit a389fd6b authored by Pietro Abate's avatar 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
......@@ -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)
......
......@@ -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
......@@ -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)
......@@ -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
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment