Bug fixed in preprocessor for new primitives.

[Faustine.git] / interpretor / basic.ml

diff --git a/interpretor/basic.ml b/interpretor/basic.ml
index cc01071..55f0fb5 100644 (file)
--- a/interpretor/basic.ml
+++ b/interpretor/basic.ml
@@ -278,23 +278,56 @@ let rec basic_power : basic -> basic -> basic =
       |        (Vec vec1, Zero) -> 
          let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
          basic_power b1 vec_zeros
-      |        (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
+      |        (Vec vec1, _) -> raise (Basic_operation "vec1 ** sca2")
       |        (N i1, _) -> basic_power (R (float_of_int i1)) b2
       |        (R f1, N i2) -> basic_power b1 (R (float_of_int i2))
       |        (R f1, R f2) -> basic_normalize (R (f1 ** f2))
-      |        (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2")
-      |        (R f1, Zero) -> R 1.
+      |        (R f1, Vec vec2) -> raise (Basic_operation "f1 ** vec2")
+      |        (R f1, Zero) -> basic_power b1 (R 0.)
       |        (R f1, Error) -> Error
       |        (Zero, N i2) -> basic_power b1 (R (float_of_int i2))
-      |        (Zero, R f2) -> R 0.
+      |        (Zero, R f2) -> basic_power (R 0.) b2
       |        (Zero, Vec vec2) -> 
          let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
          basic_power vec_zeros b2
       |        (Zero, Zero) -> basic_power (R 0.) (R 0.)
       |        (Zero, Error) -> Error
-      |        (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
+      |        (Error, Vec vec2) -> raise (Basic_operation "Error ** vec2")
       |        (Error, _) -> Error;;
 
+let rec basic_shift : (int -> int -> int) -> basic -> basic -> basic = 
+  fun oper -> fun b1 -> fun b2 ->
+    match (b1, b2) with
+    | (Vec vec1, Vec vec2) -> 
+       if vec1#size = vec2#size then 
+         Vec (new vector vec1#size 
+                (fun_binary (basic_shift oper) vec1#nth vec2#nth))
+       else raise (Basic_operation "vector size not matched.")
+    | (Vec vec1, Zero) -> 
+       let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
+       basic_shift oper b1 vec_zeros
+    | (Vec vec1, _) -> raise (Basic_operation "vec1 shift sca2")
+    | (N i1, N i2) -> basic_normalize (N (oper i1 i2))
+    | (N i1, Vec vec2) -> raise (Basic_operation "sca1 shift vec2")
+    | (N i1, Zero) -> basic_shift oper b1 (N 0)
+    | (N i1, R f2) -> 
+       raise (Basic_operation "Logical shift doesn't accept float.")
+    | (N i1, Error) -> Error
+    | (R f1, _) -> 
+       raise (Basic_operation "Logical shift doesn't accept float.")
+    | (Zero, N i2) -> basic_shift oper (N 0) b2
+    | (Zero, R f2) -> 
+       raise (Basic_operation "Logical shift doesn't accept float.")
+    | (Zero, Vec vec2) -> 
+       let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
+       basic_shift oper vec_zeros b2
+    | (Zero, Zero) -> basic_shift oper (N 0) (N 0)
+    | (Zero, Error) -> Error
+    | (Error, Vec vec2) -> raise (Basic_operation "sca1 shift vec2")
+    | (Error, _) -> Error;;
+
+let basic_shl = basic_shift (lsl);;
+let basic_shr = basic_shift (lsr);;    
 
 let rec basic_logic : 
     (bool -> bool -> bool) -> basic -> basic -> basic = 
@@ -336,11 +369,11 @@ let basic_xor = basic_logic xor;;
 let rec basic_adjust : (float -> float) -> basic -> basic = 
   fun oper -> fun b ->
     match b with
-    |N i -> R (float_of_int i)
-    |R f -> R (floor f)
+    |N i -> R (oper (float_of_int i))
+    |R f -> R (oper f)
     |Vec vec -> Vec (new vector vec#size 
                       (fun_unary (basic_adjust oper) vec#nth))
-    |Zero -> R 0.
+    |Zero -> R (oper 0.)
     |Error -> Error;;
 
 let basic_floor = basic_adjust floor;;