From 42d607127a467ca737dd903ad007d50a54533cf0 Mon Sep 17 00:00:00 2001 From: WANG Date: Wed, 11 Sep 2013 16:15:35 +0200 Subject: [PATCH] Add logical shift left (<<) and logical shift right (>>) to faustine. Succeed in compilation. Not yet tested. --- interpretor/basic.ml | 43 +++++++++++++++++++++++++++++++++++++----- interpretor/lexer.mll | 4 ++-- interpretor/process.ml | 4 ++++ interpretor/signal.ml | 2 ++ interpretor/symbol.ml | 2 ++ interpretor/types.ml | 6 ++++++ interpretor/value.ml | 2 ++ 7 files changed, 56 insertions(+), 7 deletions(-) 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;; -- 2.20.1