From: WANG <wang@wang-OptiPlex-780.(none)>
Date: Wed, 11 Sep 2013 14:15:35 +0000 (+0200)
Subject: Add logical shift left (<<) and logical shift right (>>) to faustine.
X-Git-Url: https://scm.cri.minesparis.psl.eu/git/Faustine.git/commitdiff_plain/42d607127a467ca737dd903ad007d50a54533cf0

Add logical shift left (<<) and logical shift right (>>) to faustine.
Succeed in compilation.
Not yet tested.
---

diff --git a/interpretor/basic.ml b/interpretor/basic.ml
index cc01071..1295390 100644
--- 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 = 
diff --git a/interpretor/lexer.mll b/interpretor/lexer.mll
index 9659a41..46ce90d 100644
--- a/interpretor/lexer.mll
+++ b/interpretor/lexer.mll
@@ -49,6 +49,8 @@ rule token = parse
 | "<="					{ IDENT Leq}
 | "=="					{ IDENT Eq}
 | "!="					{ IDENT Neq}
+| "<<"					{ IDENT Shl}
+| ">>"					{ IDENT Shr}
 | "max"					{ IDENT Max}
 | "min"					{ IDENT Min}
 | "prefix"                              { IDENT Prefix}
@@ -57,11 +59,9 @@ rule token = parse
 | "rdtable"                             { IDENT Rdtable}
 | "rwtable"				{ IDENT Rwtable}
 
-
 | ['0'-'9']+ as a		        { CONST a }
 | '.'                                   { POINT }
 
-
 | '('               	       	        { LPAR }
 | ')'         		                { RPAR }
 | ','					{ PAR }
diff --git a/interpretor/process.ml b/interpretor/process.ml
index 1d79f6f..ba13961 100644
--- a/interpretor/process.ml
+++ b/interpretor/process.ml
@@ -207,6 +207,10 @@ class proc_ident : faust_exp -> process_type =
 		((input#get.(0))#max input#get.(1))
 	  | Min -> self#beam_of_ident n 
 		((input#get.(0))#min input#get.(1))
+	  | Shl -> self#beam_of_ident n 
+		((input#get.(0))#shl input#get.(1))
+	  | Shr -> self#beam_of_ident n 
+		((input#get.(0))#shr input#get.(1))
 	  | Prefix -> self#beam_of_ident n 
 		((input#get.(1))#prefix input#get.(0))
 	  | Select2 -> self#beam_of_ident n 
diff --git a/interpretor/signal.ml b/interpretor/signal.ml
index f98e941..66089e9 100644
--- a/interpretor/signal.ml
+++ b/interpretor/signal.ml
@@ -149,6 +149,8 @@ class signal : rate_type -> (time -> value_type) -> signal_type =
 	method neq = self#prim2 (fun t -> (self#at t)#neq)
 	method max = self#prim2 (fun t -> (self#at t)#max)
 	method min = self#prim2 (fun t -> (self#at t)#min)
+	method shl = self#prim2 (fun t -> (self#at t)#shl)
+	method shr = self#prim2 (fun t -> (self#at t)#shr)
 
 	method delay : signal_type -> signal_type =
 	  fun (s : signal_type) ->
diff --git a/interpretor/symbol.ml b/interpretor/symbol.ml
index 967a2a6..4d58697 100644
--- a/interpretor/symbol.ml
+++ b/interpretor/symbol.ml
@@ -60,6 +60,8 @@ let dictionary_of_symbol : symbol -> (int * int) * int * string =
     |Leq 	 ->  ((2, 1), 0, "Leq")
     |Eq 	 ->  ((2, 1), 0, "Eq")
     |Neq 	 ->  ((2, 1), 0, "Neq")
+    |Shl         ->  ((2, 1), 0, "shift_left")
+    |Shr         ->  ((2, 1), 0, "shift_right")
     |Max         ->  ((2, 1), 0, "Max") 
     |Min         ->  ((2, 1), 0, "Min")
     |Prefix	 ->  ((2, 1), 0, "Prefix")
diff --git a/interpretor/types.ml b/interpretor/types.ml
index 99a3877..dd82e7c 100644
--- a/interpretor/types.ml
+++ b/interpretor/types.ml
@@ -62,6 +62,8 @@ class type value_type =
     method leq : value_type -> value_type
     method eq : value_type -> value_type
     method neq : value_type -> value_type
+    method shl : value_type -> value_type
+    method shr : value_type -> value_type
     method max : value_type -> value_type
     method min : value_type -> value_type
   end;;
@@ -109,6 +111,8 @@ type symbol = Add
 	    | Leq
 	    | Eq
 	    | Neq
+	    | Shl
+	    | Shr
 	    | Max
 	    | Min
 	    | Prefix
@@ -185,6 +189,8 @@ class type signal_type =
       method leq : signal_type -> signal_type
       method eq : signal_type -> signal_type
       method neq : signal_type -> signal_type
+      method shl : signal_type -> signal_type
+      method shr : signal_type -> signal_type
       method max : signal_type -> signal_type
       method min : signal_type -> signal_type
       method rdtable : signal_type -> signal_type -> signal_type
diff --git a/interpretor/value.ml b/interpretor/value.ml
index e9b2746..48fc31c 100644
--- a/interpretor/value.ml
+++ b/interpretor/value.ml
@@ -74,6 +74,8 @@ class value : basic -> value_type =
       method atan2 = self#prim2 basic_atan2
       method max = self#prim2 basic_max
       method min = self#prim2 basic_min
+      method shl = self#prim2 basic_shl
+      method shr = self#prim2 basic_shr
 
     end;;