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 (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 = 

diff --git a/interpretor/lexer.mll b/interpretor/lexer.mll
index 9659a41..46ce90d 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;;