CristalCaveGem » LustreC

open Vhdl_ast_pp

    | WARNING -> Printf.printf "<WARN_%s> %s" code s

    | ERROR -> Printf.printf   "<ERR_%s> %s" code s

let separator s = 

  Printf.printf "----------%s----------\n" (String.make (String.length s) '-');

  Printf.printf "--------- %s ---------\n" s;

  Printf.printf "----------%s----------\n" (String.make (String.length s) '-')

(* let count_architecture : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=

        print ~level:level ~code:code (Printf.sprintf "  Nb variables declarations in archi %s : %d\n" (to_string_name architecture.a_name) nb_var) *)

let latches_detection : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=

  fun to_string_name -> fun code -> fun level ->

      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->

(*        

        let in_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InPort)) in

        let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in

        let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in

        let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in

        let arch_writable_signals = inout_ports_names@sigs_names@out_ports_names in

        let arch_readable_signals = inout_ports_names@sigs_names@in_ports_names in

*)

        let get_latched_processes (arch : vhdl_architecture_t) : (vhdl_process_t * vhdl_sequential_stmt_t) list =

          let visitor = object (self)

            val mutable current_process = []

            val mutable latched_processes = []

            method current_process = current_process

            method latched_processes = latched_processes

            inherit [_] vhdl_iter as super_vhdl

            method! visit_vhdl_process_t env p =

              current_process <- [p];

              List.iter (super_vhdl#visit_vhdl_sequential_stmt_t env) p.p_body

            method! visit_vhdl_sequential_stmt_t env s =

              match s with

              | If ({label; if_cases; default}) -> 

                  (match default with 

                  | [] -> latched_processes <- ((List.hd current_process), s)::latched_processes;

                  | _ -> ();

                  (match if_cases with

                  | [] -> () 

                  | _ -> 

                      let sub_seq_stmts = List.flatten (List.map (function x -> x.if_block) if_cases) in

                      List.iter (self#visit_vhdl_sequential_stmt_t env) sub_seq_stmts))

              | Case ({label; guard; branches}) ->

                  let cond_exprs = guard::(List.flatten (List.map (function x -> x.when_cond) branches)) in

                  let sub_seq_stmts = List.flatten (List.map (function x -> x.when_stmt) branches) in

                  let has_others = List.exists (function c -> match c with | Others -> true | _ -> false) cond_exprs in

                  (* TODO: Needs something like: is_exhaustive_mapping cond_exprs *) (*let is_exhaustive_mapping = false in*)

                  if (not (has_others)) then (* Add test for is_exhaustive_mapping *)

                    latched_processes <- ((List.hd current_process), s)::latched_processes;

                  List.iter (self#visit_vhdl_sequential_stmt_t env) sub_seq_stmts

              | _ -> super_vhdl#visit_vhdl_sequential_stmt_t env s

            end

          in

          visitor#visit_vhdl_architecture_t () arch;

          visitor#latched_processes in

        List.iter (function (p,s) -> 

          print ~level:level ~code:code (

            Printf.sprintf "  Potentially latched process [%s] in architecture [%s]. See statement: \n%s\n"

              (to_string_name p.id)

              (to_string_name architecture.a_name)

              (show_vhdl_sequential_stmt_t s)

            )

          ) (get_latched_processes architecture)

  ("#W002",WARNING,latches_detection)

(*  ("#I001",INFO,count_architecture)*)

    separator "Structure";

    separator "Checks";