predefEvalClock.ml

(** Time-stamp: <modified the 06/03/2009 (at 14:22) by Erwan Jahier> *)

open Predef


(* exported *)
exception EvalClock_error of string


type clocker = UnifyClock.subst -> Eff.id_clock list list -> 
  Eff.id_clock list * UnifyClock.subst


(** A few useful clock profiles *)

let (constant_profile: string -> clocker) = 
  fun str s _ -> 
    let s, clk = UnifyClock.new_clock_var s in
      [Ident.of_string str, clk], s

let (op_profile: clocker) =
  fun s cl -> 
    match cl with
      | clk::_ -> clk, s
      | [] -> assert false

      
let if_clock_profile lxm sargs s = 
  function
    | [clk1; clk2; clk3] -> clk2, s
    | _ -> assert false



let rec fill x n = if n > 0 then (x::(fill x (n-1))) else []

let fillred_clock_profile lxm sargs s clks = 
  let (_, lto) = PredefEvalType.fillred_profile lxm sargs in
  let clks = List.flatten clks in
    fill (List.hd clks) (List.length lto), s 

let map_clock_profile lxm sargs s clks = 
  let (_, lto) = PredefEvalType.map_profile lxm sargs in
  let clks = List.flatten clks in
    fill (List.hd clks) (List.length lto), s

let boolred_clock_profile lxm sargs s clks = 
  let (_, lto) = PredefEvalType.boolred_profile lxm sargs in
  let clks = List.flatten clks in
    fill (List.hd clks) (List.length lto), s


(* This table contains the clock profile of predefined operators *)
let (f: op -> Lxm.t -> Eff.static_arg list -> clocker) = 
  fun op lxm sargs s ->  
    match op with
      | TRUE_n | FALSE_n | ICONST_n _ | RCONST_n _ -> 
          constant_profile (Predef.op2string op) s

      | NOT_n | REAL2INT_n | INT2REAL_n | UMINUS_n | IUMINUS_n | RUMINUS_n
      | IMPL_n | AND_n | OR_n | XOR_n 
      | NEQ_n | EQ_n | LT_n | LTE_n | GT_n | GTE_n
      | MINUS_n  |  PLUS_n |  TIMES_n |  SLASH_n  
      | RMINUS_n | RPLUS_n | RTIMES_n | RSLASH_n  
      | DIV_n | MOD_n | IMINUS_n | IPLUS_n | ISLASH_n | ITIMES_n 
      | NOR_n | DIESE_n  
          -> op_profile s

      | IF_n                 -> if_clock_profile lxm sargs s
      | Red | Fill | FillRed -> fillred_clock_profile lxm sargs s
      | Map                  -> map_clock_profile lxm sargs s
      | BoolRed              -> boolred_clock_profile lxm sargs s