CristalCaveGem » LustreC

(*                     Basic      Printing functions                                        *)

let pp_final_char_if_non_empty c l =

  (fun fmt -> match l with [] -> () | _ -> fprintf fmt "%s" c)

let pp_newline_if_non_empty l =

  (fun fmt -> match l with [] -> () | _ -> fprintf fmt "@,")

let pp_dimension fmt d =

  Printers.pp_expr fmt (expr_of_dimension d)

let pp_type fmt t = 

    | Types.Tbool -> pp_print_string fmt "boolean" 

    | Types.Treal -> pp_print_string fmt "double" 

    | _ -> Types.print_ty fmt t

let pp_tag fmt t =

 pp_print_string fmt t

    | Const_int i -> pp_print_int fmt i

    | Const_real r -> pp_print_string fmt r

    | Const_float r -> pp_print_float fmt r

    | Const_tag t -> pp_tag fmt t

    | Const_array ca -> Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_const) ca

    | Cst c -> pp_const fmt c

    | Var v ->

       if is_state_vars m.memories v then

         fprintf fmt "%s" v

       else

         if List.exists (fun o -> o.var_id = v) m.mstep.step_outputs then

	   fprintf fmt "*%s" v

         else

	   pp_print_string fmt v

    | Fun (n, vl) -> if Basic_library.is_internal_fun n then

	Basic_library.pp_java n (pp_val m) fmt vl

      else

	fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " (pp_val m)) vl

  if List.exists (fun o -> o.var_id = i) m.mstep.step_outputs

  then

  else

    fprintf fmt "&%s" i

(*                    Instruction Printing functions                                        *)

  try 

    | MReset i -> (

      match List.assoc i m.minstances with

	| "_arrow" -> fprintf fmt "%s = true;" i

	| _ -> fprintf fmt "%s.reset();" i

    )

    | MLocalAssign (i,v) -> (

      fprintf fmt "%s = %a;" 

	i (pp_val m) v

    )

    | MStateAssign (i,v) ->

      fprintf fmt "%s = %a;" i (pp_val m) v

    | MStep ([i0], i, vl) when Basic_library.is_internal_fun i ->

      fprintf fmt "%s = %a;" i0 (Basic_library.pp_java i (pp_val m)) vl    

    | MStep ([i0], i, [init; step]) when ((List.assoc i m.minstances) = "_arrow") -> (

      fprintf fmt "@[<v 2>if (%s) {@,%s = false;@,%s = %a;@]@,@[<v 2>} else {@,%s = %a;@]@,};@,"

	    i i i0 (pp_val m) init i0 (pp_val m) step

    )

    | MStep (il, i, vl) -> (

      let out = 

	try

	  List.assoc i instance_out_list 

	with Not_found -> (eprintf "impossible to find instance %s in the list@.@?" i; 

			   assert false) 

      in 

	  fprintf fmt "%s = %s.step (%a);@,"

    	    out i

     	    (Utils.fprintf_list ~sep:", " (pp_val m)) vl;

	  Utils.fprintf_list ~sep:"@," 

	    (fun fmt (o, oname) -> fprintf fmt "%s = %s.%s;" o out oname) fmt 

	    (List.map2 

	       (fun x y -> x, y.var_id) 

	       il 

	       (get_output_of_machine machines (List.assoc i m.minstances))

	    ) 

    ) 

    | MBranch (g,hl) ->

      Format.fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"

	(pp_val m) g

	(Utils.fprintf_list ~sep:"@," (pp_machine_branch m machines instance_out_list)) hl

  Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr m machines instance_out_list)) h

(*                         Java file Printing functions                                        *)

let get_class_name n = match n with "_arrow" -> "boolean" | _ -> String.capitalize n

let pp_local_fields visibility = 

  fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "%s %a;" visibility pp_var v) 

let pp_local_field_instances = 

  fprintf_list ~sep:"@," 

    (fun fmt (node_inst, node_type) -> fprintf fmt "protected %s %s;" 

      (get_class_name node_type) 

      node_inst

    ) 

    (fprintf_list ~sep:"; " pp_var) outputs

    (fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "this.%s = %s;" v.var_id v.var_id)) outputs

let pp_output_class fmt step = 

    (pp_local_fields "public") step.step_outputs

    pp_output_constructor step.step_outputs

let pp_constructor fmt (name, instances) = 

  fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@,"

    (String.capitalize name)

    (

      fprintf_list ~sep:"@," 

	(fun fmt (node_inst, node_type) -> 

	  match node_type with

	      "_arrow" -> fprintf fmt "%s = true;" node_inst

	    | _ -> fprintf fmt "%s = new %s();" node_inst (get_class_name node_type) 

	) 

    ) 

let pp_reset machines fmt m = 

    (fprintf_list ~sep:"@," (pp_machine_instr m machines [])) m.minit

let pp_step machines fmt m : unit = 

  let out_assoc_list = 

  fprintf fmt 

    "@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@,"

    (Utils.fprintf_list ~sep:",@ " pp_var) m.mstep.step_inputs

    (Utils.fprintf_list ~sep:";@," pp_var) m.mstep.step_locals

    (pp_final_char_if_non_empty ";" m.mstep.step_locals) 

    (fprintf_list ~sep:"" 

       (fun fmt (ninst, ntype) -> fprintf fmt "%s.Output out_%s;@," (get_class_name ntype) ninst )) 

    (List.filter (fun (_,ntyp) -> not (ntyp = "_arrow")) m.minstances)

    (fprintf_list ~sep:";@," pp_var) m.mstep.step_outputs

    (pp_final_char_if_non_empty ";" m.mstep.step_outputs) 

    (fprintf_list ~sep:"@," (pp_machine_instr m machines out_assoc_list)) m.mstep.step_instrs     

    (fun fmt -> fprintf fmt "return new Output(%a);" 

      (fprintf_list ~sep:"," (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_outputs 

    )

  if m.mname.node_id = "_arrow" then () else ( (* We don't print arrow function *)

      (String.capitalize m.mname.node_id) (* class name *)

      (pp_local_fields "protected") m.mmemory                      (* fields *)

      (pp_newline_if_non_empty m.mmemory)            

      pp_local_field_instances m.minstances          (* object fields *)

      (pp_newline_if_non_empty m.minstances)         

      (pp_newline_if_non_empty m.minstances)         

      pp_output_class m.mstep                        (* class for output of step method *)

      pp_constructor (m.mname.node_id, m.minstances) (* constructor to instanciate object fields *)

      (pp_reset machines) m                               (* reset method *)

      (pp_step machines) m             (* step method *)

  )

(*                         Main related functions                                           *)

(*     | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id *)

let read_input fmt typ = match typ.Types.tdesc with

  | Types.Treal -> fprintf fmt "StdIn.readDouble()"

  | Types.Tint ->  fprintf fmt "StdIn.readInt()"

  | Types.Tbool ->  fprintf fmt "StdIn.readBoolean()"

  | _ -> assert false

    (fun fmt -> fprintf fmt "%s main_node = new %s();"  m_class m_class)

    (fun fmt -> fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"  

      (fprintf_list ~sep:"@," 

	 (fun fmt v -> fprintf fmt "System.out.println(\"%s?\");@,%a = %a;" 

	   v.var_id pp_var v read_input v.var_type))

      m.mstep.step_inputs

      (fun fmt -> fprintf fmt "%s.Output out = main_node.step(%a);" 

	m_class  

	(fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs

      )

      (fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id v.var_id))

      m.mstep.step_outputs

    )

(*     (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *)

(*     (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *)

(*   else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname); *)

(* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)

(* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)

(* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)

(* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)

(* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)

(* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)

(* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)

(*   fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"io_frontend.h\"@." *)

(*                         Translation function                                             *)

      | "" -> (fun _ -> ())

      | main_node -> (

  	let main_node_opt =

  	  List.fold_left

  	    (fun res m ->

  	      match res with

  		| Some _ -> res

  		| None -> if m.mname.node_id = main_node then Some m else None)

  	    None machines

	in

	match main_node_opt with

  	  | None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ())

  	  | Some m -> print_main_fun basename machines m

      )

  main_print source_fmt