Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / tools / importer / mini_vhdl_check.ml @ a16d29bf

History | View | Annotate | Download (4.44 KB)

1
open Vhdl_ast
2
open Mini_vhdl_ast
3
open Vhdl_2_mini_vhdl_map
4
open Mini_vhdl_utils
5

    
6
(*
7
type db_tuple_t =
8
  {
9
    mutable entity: vhdl_entity_t;
10
    mutable architecture: vhdl_architecture_t;
11
    mutable architecture_signals: mini_vhdl_declaration_t list;
12
    mutable architecture_ports: vhdl_port_t list;
13
    mutable architecture_generics: vhdl_port_t list;
14
    mutable assigned_signals_names: vhdl_name_t list;
15
    mutable contexts: vhdl_load_t list;
16
  }
17
*)
18

    
19
type level = INFO | WARNING | ERROR
20

    
21
let print ?(level = INFO) ?(code = "") s =
22
  match s with
23
  | "" -> ()
24
  | _ -> match level with
25
    | INFO -> Printf.printf    "<INFO> %s" s
26
    | WARNING -> Printf.printf "<WARNING =%s=> %s" code s
27
    | ERROR -> Printf.printf   "<ERROR =%s=> %s" code s
28

    
29
let filter_display s l to_string_name = match l with
30
  | [] -> ""
31
  | _ -> Printf.sprintf "%s [%s]\n" s (String.concat ", " (List.map to_string_name l))
32

    
33
(**
34
 * Display
35
 *)
36
let display_struct_content : (vhdl_name_t -> string) -> db_tuple_t -> unit =
37
  fun to_string_name ->
38
    fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
39
      let arch_name = to_string_name architecture.name in
40
      let ent_name = to_string_name entity.name in
41
      let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in
42
      let in_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InPort)) in
43
      let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in
44
      let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in
45
      let generics_names = List.flatten (List.map get_names architecture_generics) in
46
      print (Printf.sprintf "Details for architecture [%s] of entity [%s]\n" arch_name ent_name);
47
      print (filter_display "  Inner signals" sigs_names to_string_name);
48
      print (filter_display "  In ports" in_ports_names to_string_name);
49
      print (filter_display "  InOut ports" inout_ports_names to_string_name);
50
      print (filter_display "  Out ports" out_ports_names to_string_name);
51
      print (filter_display "  Generics" generics_names to_string_name);
52
      print (filter_display "  Assigned names" (List.sort_uniq compare assigned_signals_names) to_string_name)
53

    
54
(**
55
 * Checks
56
 * All checks should have the same signature:
57
 *  (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit
58
 *)
59
let check_error_duplicate_signal_assignment : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
60
  fun to_string_name -> fun code -> fun level ->
61
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
62
        let dupl = duplicates assigned_signals_names in
63
        if List.length dupl > 0
64
          then print ~level:level ~code:code (Printf.sprintf " Duplicate concurrent assignment of %s" (filter_display "signal" dupl to_string_name))
65
          else ()
66

    
67
let check_missing_signal_assignment : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
68
  fun to_string_name -> fun code -> fun level ->
69
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
70
        let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in
71
        let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in
72
        let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in
73
        let declared_signals = inout_ports_names@sigs_names@out_ports_names in
74
        let uniq_assigned_signals = List.sort_uniq compare assigned_signals_names in
75
        let missing = diff declared_signals uniq_assigned_signals to_string_name in
76
        if List.length missing > 0
77
          then print ~level:level ~code:code (Printf.sprintf " Missing assignment of %s" (filter_display "signal" missing to_string_name))
78
          else ()
79

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

    
82
(**
83
 * Main
84
 *)
85
let check_mini_vhdl db to_string_name =
86
  let rec iter_checks checks x = match checks with
87
    | [] -> ()
88
    | (code,level,check)::tl -> check to_string_name code level x; iter_checks tl x in
89
  let disp_and_check x =
90
    display_struct_content to_string_name x;
91
    iter_checks checks x in
92
  List.iter disp_and_check db;