CristalCaveGem » LustreC

(* Print machine code values as matlab expressions. Variable identifiers are

   replaced by uX where X is the index of the variables in the list vars of input

   variables. *)

  (* eprintf "print %s with %i args@.@?" id (List.length vl);*)

(* detect whether the instruction i represents an ARROW, ie an arrow with true -> false *)

let is_arrow_fun m i =

    let name = try (Machine_code.get_node_def i m).node_id with Not_found -> Format.eprintf "Impossible to find node %s@.@?" i; raise Not_found in

(* pp_basic_instr prints regular instruction. These do not contain MStep which

   should have been already filtered out. Another restriction which is supposed

   to be enforced is that branching statement contain a single instruction (in

   practice it has to be an assign) *)

let rec pp_basic_instr m vars fmt i =

  | MBranch (g,[(tag1,[case1]);(tag2,[case2])])     ->

     (* Thanks to normalization with join_guards = false, branches shall contain

	a single expression *)

       (pp_basic_instr m vars) then_case

       (pp_basic_instr m vars) else_case

    -> Format.eprintf "unhandled branch in EMF@.@?"; assert false

    -> Format.eprintf "unhandled reset in EMF@.@?"; assert false

    -> Format.eprintf "unhandled noreset in EMF@.@?"; assert false

  | MStep _ (* function calls already handled, including STEP *)

    -> Format.eprintf "unhandled function call in EMF (should have been filtered out before)@.@?";

      assert false

  | MComment _ 

    -> Format.eprintf "unhandled comment in EMF@.@?"; assert false

      (* not  available for EMF output *)

  | MStep (_, _, vl)  -> List.fold_left (fun res v -> Utils.ISet.union res (get_val_vars v)) Utils.ISet.empty vl 

  | MBranch (c,[(_,[case1]);(_,[case2])])     ->

	   (get_instr_vars case1)

	   (get_instr_vars case2)

(* and get_instrs_vars il = *)

(*   List.fold_left (fun res i -> Utils.ISet.union res (get_instr_vars i)) *)

(*     Utils.ISet.empty *)

(*     il *)

  | MStep _ when is_arrow_fun m i -> () (* we print nothing, this is a STEP *)

let pp_emf_instrs m fmt i =

  (* Either it is a Step function non arrow, then we have a dedicated treatment,

     or it has to be a single variable assigment *)

  let arguments_vars = Utils.ISet.elements (get_instr_vars i) in	

  match Corelang.get_instr_desc i with

    (* Regular node call either a statuful node or a functional one *)

    MStep (outputs, f, inputs) when not (is_arrow_fun m i) -> (

      fprintf fmt "\"__functioncall\": @[<v 2>{ \"node\": \"%s\",@ \"inputs\": [%a],@ \"vars\": [%a]@ \"outputs\": [%a],@ \"original_lustre_expr\": [%a]@]}"

	((Machine_code.get_node_def f m).node_id) (* Node name *)

        (Utils.fprintf_list ~sep:", " (fun fmt _val -> fprintf fmt "\"%a\"" (pp_val arguments_vars) _val)) inputs                  (* inputs *)

	(fprintf_list ~sep:", " pp_var_string) arguments_vars

	(fprintf_list ~sep:", " (fun fmt v -> pp_var_string fmt v.var_id)) outputs  (* outputs *)

	(pp_original_lustre_expression m) i         (* original lustre expr *)

    )

  | _ ->

     (* Other expressions, including "pre" *)

     ( 

    (* first, we extract the expression and associated variables *)

    let var = get_instr_var i in

    fprintf fmt "\"%s\": @[<v 2>{ \"expr\": \"%a\",@ \"vars\": [%a] @ \"original_lustre_expr\": [%a]@]}"

      var.var_id

      (fun fmt i -> match Corelang.get_instr_desc i with

      | MStep _ -> fprintf fmt "STEP"

      | _ -> pp_basic_instr m arguments_vars fmt i) i

      (fprintf_list ~sep:", " pp_var_string) arguments_vars

      (pp_original_lustre_expression m) i

  )

      (fprintf_list ~sep:",@ " (pp_emf_instrs m)) m.mstep.step_instrs;

  (* Previous alternative: mapping normalized lustre to EMF: 

     fprintf_list ~sep:",@ " pp_decl fmt prog; *)