Project

General

Profile

Download (4.16 KB) Statistics
| Branch: | Tag: | Revision:
1
open Vhdl_ast
2
open Mini_vhdl_ast
3
open Vhdl_2_mini_vhdl_map
4
open Mini_vhdl_utils
5

    
6
type level = INFO | WARNING | ERROR
7

    
8
let print ?(level = INFO) ?(code = "") s =
9
  match s with
10
  | "" -> ()
11
  | _ -> match level with
12
    | INFO -> Printf.printf    "<INFO> %s" s
13
    | WARNING -> Printf.printf "<WARNING =%s=> %s" code s
14
    | ERROR -> Printf.printf   "<ERROR =%s=> %s" code s
15

    
16
let filter_display s l to_string_name = match l with
17
  | [] -> ""
18
  | _ -> Printf.sprintf "%s [%s]\n" s (String.concat ", " (List.map to_string_name l))
19

    
20
(**
21
 * Display
22
 *)
23
let display_struct_content : (vhdl_name_t -> string) -> db_tuple_t -> unit =
24
  fun to_string_name ->
25
    fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; memories; contexts} ->
26
      let arch_name = to_string_name architecture.name in
27
      let ent_name = to_string_name entity.name in
28
      let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in
29
      let in_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InPort)) in
30
      let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in
31
      let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in
32
      let generics_names = List.flatten (List.map get_names architecture_generics) in
33
      print (Printf.sprintf "Details for architecture [%s] of entity [%s]\n" arch_name ent_name);
34
      print (filter_display "  Inner signals" sigs_names to_string_name);
35
      print (filter_display "  In ports" in_ports_names to_string_name);
36
      print (filter_display "  InOut ports" inout_ports_names to_string_name);
37
      print (filter_display "  Out ports" out_ports_names to_string_name);
38
      print (filter_display "  Generics" generics_names to_string_name);
39
      print (filter_display "  Assigned names" (List.sort_uniq compare assigned_signals_names) to_string_name);
40
      print (filter_display "  Memories" (List.sort_uniq compare memories) to_string_name)
41

    
42
(**
43
 * Checks
44
 * All checks should have the same signature:
45
 *  (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit
46
 *)
47
let check_error_duplicate_signal_assignment : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
48
  fun to_string_name -> fun code -> fun level ->
49
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
50
        let dupl = duplicates assigned_signals_names in
51
        if List.length dupl > 0
52
          then print ~level:level ~code:code (Printf.sprintf " Duplicate concurrent assignment of %s" (filter_display "signal" dupl to_string_name))
53
          else ()
54

    
55
let check_missing_signal_assignment : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
56
  fun to_string_name -> fun code -> fun level ->
57
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
58
        let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in
59
        let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in
60
        let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in
61
        let declared_signals = inout_ports_names@sigs_names@out_ports_names in
62
        let uniq_assigned_signals = List.sort_uniq compare assigned_signals_names in
63
        let missing = diff declared_signals uniq_assigned_signals in
64
        if List.length missing > 0
65
          then print ~level:level ~code:code (Printf.sprintf " Missing assignment of %s" (filter_display "signal" missing to_string_name))
66
          else ()
67

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

    
70
(**
71
 * Main
72
 *)
73
let check_mini_vhdl db to_string_name =
74
  let rec iter_checks checks x = match checks with
75
    | [] -> ()
76
    | (code,level,check)::tl -> check to_string_name code level x; iter_checks tl x in
77
  let disp_and_check x =
78
    display_struct_content to_string_name x;
79
    iter_checks checks x in
80
  List.iter disp_and_check db;
(2-2/3)