CristalCaveGem » LustreC

open Vhdl_ast

open Mini_vhdl_ast

open Vhdl_2_mini_vhdl_map

open Mini_vhdl_utils

(*

type db_tuple_t =

  {

    mutable entity: vhdl_entity_t;

    mutable architecture: vhdl_architecture_t;

    mutable architecture_signals: mini_vhdl_declaration_t list;

    mutable architecture_ports: vhdl_port_t list;

    mutable architecture_generics: vhdl_port_t list;

    mutable assigned_signals_names: vhdl_name_t list;

    mutable contexts: vhdl_load_t list;

  }

*)

type level = INFO | WARNING | ERROR

let print ?(level = INFO) ?(code = "") s =

  match s with

  | "" -> ()

  | _ -> match level with

    | INFO -> Printf.printf    "<INFO> %s" s

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

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

let filter_display s l to_string_name = match l with

  | [] -> ""

  | _ -> Printf.sprintf "%s [%s]\n" s (String.concat ", " (List.map to_string_name l))

(**

 * Display

 *)

let display_struct_content : (vhdl_name_t -> string) -> db_tuple_t -> unit =

  fun to_string_name ->

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

      let arch_name = to_string_name architecture.name in

      let ent_name = to_string_name entity.name in

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

      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 generics_names = List.flatten (List.map get_names architecture_generics) in

      print (Printf.sprintf "Details for architecture [%s] of entity [%s]\n" arch_name ent_name);

      print (filter_display "  Inner signals" sigs_names to_string_name);

      print (filter_display "  In ports" in_ports_names to_string_name);

      print (filter_display "  InOut ports" inout_ports_names to_string_name);

      print (filter_display "  Out ports" out_ports_names to_string_name);

      print (filter_display "  Generics" generics_names to_string_name);

      print (filter_display "  Assigned names" (List.sort_uniq compare assigned_signals_names) to_string_name)

(**

 * Checks

 * All checks should have the same signature:

 *  (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit

 *)

let check_error_duplicate_signal_assignment : (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 dupl = duplicates assigned_signals_names in

        if List.length dupl > 0

          then print ~level:level ~code:code (Printf.sprintf " Duplicate concurrent assignment of %s" (filter_display "signal" dupl to_string_name))

          else ()

let check_missing_signal_assignment : (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 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 declared_signals = inout_ports_names@sigs_names@out_ports_names in

        let uniq_assigned_signals = List.sort_uniq compare assigned_signals_names in

        let missing = diff declared_signals uniq_assigned_signals to_string_name in

        if List.length missing > 0

          then print ~level:level ~code:code (Printf.sprintf " Missing assignment of %s" (filter_display "signal" missing to_string_name))

          else ()

let checks = [("#E001",ERROR,check_error_duplicate_signal_assignment); ("#W001",WARNING,check_missing_signal_assignment)] 

(**

 * Main

 *)

let check_mini_vhdl db to_string_name =

  let rec iter_checks checks x = match checks with

    | [] -> ()

    | (code,level,check)::tl -> check to_string_name code level x; iter_checks tl x in

  let disp_and_check x =

    display_struct_content to_string_name x;

    iter_checks checks x in

  List.iter disp_and_check db;