[r2002-10-26 18:42:59 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 18:43:00+00:00

parser/parser.ml

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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