CristalCaveGem » LustreC

open Vhdl_ast

open Mini_vhdl_ast

open Vhdl_ast_fold_sensitivity

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_names: vhdl_name_t list;

    mutable contexts: vhdl_load_t list;

  }

let get_sensitivity_list = object (self)

  inherit ['acc] fold_sensitivity as super

end

let _ = fun (_ : vhdl_cst_val_t)  -> () 

let _ = fun (_ : vhdl_type_t)  -> () 

let _ = fun (_ : vhdl_element_declaration_t)  -> () 

let _ = fun (_ : vhdl_subtype_indication_t)  -> () 

let _ = fun (_ : vhdl_discrete_range_t)  -> () 

let _ = fun (_ : vhdl_constraint_t)  -> () 

let _ = fun (_ : vhdl_definition_t)  -> () 

let _ = fun (_ : vhdl_expr_t)  -> () 

let _ = fun (_ : vhdl_name_t)  -> () 

let _ = fun (_ : vhdl_assoc_element_t)  -> () 

let _ = fun (_ : vhdl_element_assoc_t)  -> () 

let _ = fun (_ : vhdl_array_attributes_t)  -> () 

let _ = fun (_ : vhdl_signal_attributes_t)  -> () 

let _ = fun (_ : vhdl_string_attributes_t)  -> () 

let _ = fun (_ : vhdl_suffix_selection_t)  -> () 

let _ = fun (_ : 'basetype vhdl_type_attributes_t)  -> () 

let _ = fun (_ : vhdl_parameter_t)  -> () 

let _ = fun (_ : vhdl_subprogram_spec_t)  -> () 

let _ = fun (_ : vhdl_sequential_stmt_t)  -> () 

let _ = fun (_ : vhdl_if_case_t)  -> () 

let _ = fun (_ : vhdl_case_item_t)  -> () 

let _ = fun (_ : vhdl_declaration_t)  -> () 

let _ = fun (_ : vhdl_signal_selection_t)  -> () 

let _ = fun (_ : vhdl_declarative_item_t)  -> () 

let _ = fun (_ : vhdl_waveform_element_t)  -> ()

let _ = fun (_ : vhdl_signal_condition_t)  -> () 

let _ = fun (_ : vhdl_conditional_signal_t)  -> () 

let _ = fun (_ : vhdl_process_t)  -> () 

let _ = fun (_ : vhdl_selected_signal_t)  -> () 

let _ = fun (_ : vhdl_port_mode_t)  -> () 

let _ = fun (_ : vhdl_component_instantiation_t)  -> ()

let _ = fun (_ : vhdl_concurrent_stmt_t)  -> () 

let _ = fun (_ : vhdl_port_t)  -> () 

let _ = fun (_ : vhdl_entity_t)  -> () 

let _ = fun (_ : vhdl_package_t)  -> () 

let _ = fun (_ : vhdl_load_t)  -> () 

let _ = fun (_ : vhdl_architecture_t)  -> () 

let _ = fun (_ : vhdl_configuration_t)  -> () 

let _ = fun (_ : vhdl_library_unit_t)  -> () 

let _ = fun (_ : vhdl_design_unit_t)  -> () 

let _ = fun (_ : vhdl_design_file_t)  -> () 

class virtual vhdl_2_mini_vhdl_map =

  object (self)

    method virtual  string : string -> string

    method virtual  list : 'a . ('a -> 'a) -> 'a list -> 'a list

    method virtual  unit : unit -> unit

    method virtual  bool : bool -> bool

    method virtual  option : 'a . ('a -> 'a) -> 'a option -> 'a option

    method virtual  int : int -> int

    method virtual  vhdl_name_t : vhdl_name_t -> vhdl_name_t

    method virtual  vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t

    method virtual  vhdl_port_t : vhdl_port_t -> vhdl_port_t

    method virtual  vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t

    method virtual  vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t

    method virtual  vhdl_element_declaration_t : vhdl_element_declaration_t -> vhdl_element_declaration_t

    method virtual  vhdl_subtype_indication_t : vhdl_subtype_indication_t -> vhdl_subtype_indication_t

    method virtual  vhdl_conditional_signal_t : vhdl_conditional_signal_t -> vhdl_conditional_signal_t

    method virtual  vhdl_selected_signal_t : vhdl_selected_signal_t -> vhdl_selected_signal_t

    method virtual  vhdl_signal_selection_t : vhdl_signal_selection_t -> vhdl_signal_selection_t

    method virtual  vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t

    method virtual  vhdl_waveform_element_t : vhdl_waveform_element_t -> vhdl_waveform_element_t

    method virtual  vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t

    method virtual  vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t

    method virtual  vhdl_subprogram_spec_t : vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t

    method virtual  vhdl_discrete_range_t : vhdl_discrete_range_t -> vhdl_discrete_range_t

    method virtual  vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t

    method virtual  vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t

    method virtual  vhdl_configuration_t : vhdl_configuration_t -> unit

    method virtual  vhdl_entity_t : vhdl_entity_t -> unit

    method virtual  vhdl_library_unit_t : vhdl_library_unit_t -> unit

    method virtual  vhdl_load_t : vhdl_load_t -> vhdl_load_t

    method virtual  vhdl_design_unit_t : vhdl_design_unit_t -> unit

    method virtual  vhdl_declarative_item_t : vhdl_declarative_item_t -> mini_vhdl_declarative_item_t

    method virtual  vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t

    method virtual  vhdl_concurrent_stmt_t : vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t

    method virtual  vhdl_sequential_stmt_t : vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t

    method virtual  vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t

    method virtual  vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t

    method virtual  vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *

                                  (vhdl_load_t list * vhdl_entity_t) list * 

                                  (vhdl_load_t list * vhdl_configuration_t) list *

                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t

    method virtual  vhdl_component_instantiation_t : vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t

    method virtual  declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list

    method virtual  declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list

    method virtual  declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list

    method virtual  filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 

                           (vhdl_load_t list * vhdl_entity_t)

(*************************

 * Begin vhdl_name_t helpers

 *)

    method simplify_name_t : vhdl_name_t -> vhdl_name_t=

      fun n ->

        let lower a = String.lowercase_ascii a in

        let n = self#lower_vhdl_name_t n in

        match n with

        | Selected (a::[]) -> self#simplify_name_t a

        | Selected (NoName::tl) -> self#simplify_name_t (Selected tl)

        | Selected ((Simple (s))::tl) ->  if (lower s = "work")

                                          then self#simplify_name_t (Selected tl)

                                          else n

        | Selected ((Identifier (s))::tl) -> if (lower s = "work")

                                             then self#simplify_name_t (Selected tl)

                                             else n

        | _ -> n

    method lower_vhdl_name_t : vhdl_name_t -> vhdl_name_t=

      fun x  ->

        let lower a = String.lowercase_ascii a in

        match x with

        | Simple a -> Simple (lower a)

        | Identifier a -> Identifier (lower a)

        | Selected a -> Selected (self#list self#lower_vhdl_name_t a)

        | Index { id; exprs } ->

            let id = self#lower_vhdl_name_t id  in

            let exprs = self#list self#vhdl_expr_t exprs  in

            Index { id; exprs }

        | Slice { id; range } ->

            let id = self#lower_vhdl_name_t id  in

            let range = self#vhdl_discrete_range_t range  in

            Slice { id; range }

        | Attribute { id; designator; expr } ->

            let id = self#lower_vhdl_name_t id  in

            let designator = self#lower_vhdl_name_t designator  in

            let expr = self#vhdl_expr_t expr  in

            Attribute { id; designator; expr }

        | Function { id; assoc_list } ->

            let id = self#lower_vhdl_name_t id  in

            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list in

            Function { id; assoc_list }

        | NoName  -> NoName

    method to_string_vhdl_name_t : vhdl_name_t -> string=

      fun x  ->

        match x with

        | Simple a -> a

        | Identifier a -> a

        | Selected a -> String.concat "." (List.map self#to_string_vhdl_name_t a)

        | Index { id; exprs } -> self#to_string_vhdl_name_t id

        | Slice { id; range } -> self#to_string_vhdl_name_t id

        | Attribute { id; designator; expr } -> self#to_string_vhdl_name_t id

        | Function { id; assoc_list } -> self#to_string_vhdl_name_t id

        | NoName  -> "NoName"

    method flatten_vhdl_name_t : vhdl_name_t -> vhdl_name_t=

      fun x  ->

        match x with

        | Simple a -> Simple (a)

        | Identifier a -> Simple (a)

        | Selected (hd::tl) -> Simple (String.concat "__" ((self#to_string_vhdl_name_t (self#flatten_vhdl_name_t hd))::[self#to_string_vhdl_name_t (self#flatten_vhdl_name_t (Selected (tl)))]))

        | _ -> failwith ("Impossible to flatten name value [" ^ self#to_string_vhdl_name_t x ^ "]")

    method postfix_flatten_vhdl_name_t : vhdl_name_t -> string -> vhdl_name_t=

      fun x  ->

        fun postfix ->

          let flattened = self#flatten_vhdl_name_t x in

          match flattened with

          | Simple a -> Simple (a ^ postfix)

          | Identifier a -> Identifier (a ^ postfix)

          | _ -> failwith ("Impossible to postfix name value [" ^ self#to_string_vhdl_name_t x ^ "]")

(*************************

 * End vhdl_name_t helpers

 *)

(*************************

 * Begin DB helpers

 *)

    val mutable db : db_tuple_t list = []

    method get_db : db_tuple_t list = db

    method db_add_tuple : db_tuple_t -> unit=

      fun x -> db <- x::db

    method db_get : vhdl_architecture_t -> (vhdl_entity_t * vhdl_load_t list)=

      fun x ->

        let rec find a dbl =

          match dbl with

          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t x.name ^ "]")

          | e::tl -> if (e.architecture = a) then (e.entity, e.contexts) else find a tl in find x db

    method get_tuple_from_archi_and_entity_name : (vhdl_name_t * vhdl_name_t) -> db_tuple_t=

      fun (a_name,e_name) ->

        let a_name = self#simplify_name_t a_name in

        let e_name = self#simplify_name_t e_name in

        let rec find (a_name,e_name) dbl =

          match dbl with

          | [] -> failwith ("No matching tuple in DB for architecture [" ^ self#to_string_vhdl_name_t a_name ^

                           "] and entity [" ^ self#to_string_vhdl_name_t e_name ^ "]")

          | e::tl -> 

              let inner_e_arch_name = self#simplify_name_t e.architecture.name in

              let inner_e_ent_name = self#simplify_name_t e.entity.name in

              if ((inner_e_arch_name = a_name) && (inner_e_ent_name = e_name)) 

              then e 

              else find (a_name,e_name) tl in 

        find (a_name,e_name) db

    method filter_entity : ((vhdl_load_t list * vhdl_entity_t) list * vhdl_name_t) -> 

                           (vhdl_load_t list * vhdl_entity_t) =

      fun ( entities_pair, filter_name ) ->

      let rec filter ep n = match ep with

      | [] -> failwith ("Impossible to find an entity with name [" ^ self#to_string_vhdl_name_t filter_name ^ "]")

      | (c,{name; generics; ports; declaration; stmts})::tl -> 

          if (name = n) then 

            List.hd ep

          else filter (List.tl ep) n in

      filter entities_pair filter_name

(*******************

 * End DB helpers

 *)

(*******************

 * Begin declarative_item_t projections

 *)

    method declarative_items_declarations : vhdl_declarative_item_t list -> vhdl_declaration_t list =

      fun x ->

        match x with

        | {use_clause=_; declaration=Some a;definition=_}::tl -> a::(self#declarative_items_declarations tl)

        | _::tl -> self#declarative_items_declarations tl

        | [] -> []

    method declarative_items_definitions : vhdl_declarative_item_t list -> vhdl_definition_t list =

      fun x ->

        match x with

        | {use_clause=_; declaration=_;definition=Some a}::tl -> a::(self#declarative_items_definitions tl)

        | _::tl -> self#declarative_items_definitions tl

        | [] -> []

    method declarative_items_uses : vhdl_declarative_item_t list -> vhdl_load_t list =

      fun x ->

        match x with

        | {use_clause=Some a; declaration=_;definition=_}::tl -> a::(self#declarative_items_uses tl)

        | _::tl -> self#declarative_items_uses tl

        | [] -> []

(******************

 * End declarative_item_t projections

 *)

(*****************

 * Begin names_t extraction

 *)

    method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=

      fun x ->

        match x with

        | Process a -> List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.body)

        | ComponentInst a -> []

    method mini_vhdl_sequential_stmt_t_assigned_signals_names :

      mini_vhdl_sequential_stmt_t -> vhdl_name_t list=

      fun x  ->

        match x with

        | VarAssign { label; lhs; rhs } -> [lhs]

        | SigSeqAssign { label; lhs; rhs } -> [lhs]

        | SigCondAssign { label; lhs; rhs; delay} -> [lhs]

        | SigSelectAssign { label; lhs; sel; branches; delay } -> [lhs]

        | If { label; if_cases; default } -> 

            let if_cases_stmts = List.flatten (List.map (fun x -> x.if_block) if_cases) in

            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (if_cases_stmts@default))

        | Case { label; guard; branches } ->

            let case_branches_stmts = List.flatten (List.map (fun x -> x.when_stmt) branches) in

            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names case_branches_stmts)

        | ProcedureCall { label; name; assocs } -> [] (* TODO: resolve this *)

        | _ -> []

(****************

 *End names_t extraction

 *)

    method vhdl_cst_val_t : vhdl_cst_val_t -> vhdl_cst_val_t=

      fun x  ->

        match x with

        | CstInt a -> let a = self#int a  in CstInt a

        | CstStdLogic a -> let a = self#string a  in CstStdLogic a

        | CstLiteral a -> let a = self#string a  in CstLiteral a

    method vhdl_type_t : vhdl_type_t -> vhdl_type_t=

      fun x  ->

        match x with

        | Base a -> let a = self#string a  in Base a

        | Range (a,b,c) ->

            let a = self#option self#string a  in

            let b = self#int b  in let c = self#int c  in Range (a, b, c)

        | Bit_vector (a,b) ->

            let a = self#int a  in let b = self#int b  in Bit_vector (a, b)

        | Array { indexes; const; definition } ->

            let indexes = self#list self#lower_vhdl_name_t indexes  in

            let const = self#option self#vhdl_constraint_t const  in

            let definition = self#vhdl_subtype_indication_t definition  in

            Array { indexes; const; definition }

        | Record a ->

            let a = self#list self#vhdl_element_declaration_t a  in Record a

        | Enumerated a ->

            let a = self#list self#lower_vhdl_name_t a  in Enumerated a

        | Void  -> Void

    method vhdl_element_declaration_t :

      vhdl_element_declaration_t -> vhdl_element_declaration_t=

      fun { names; definition }  ->

        let names = self#list self#lower_vhdl_name_t names  in

        let definition = self#vhdl_subtype_indication_t definition  in

        { names; definition }

    method vhdl_subtype_indication_t :

      vhdl_subtype_indication_t -> vhdl_subtype_indication_t=

      fun { name; functionName; const }  ->

        let name = self#lower_vhdl_name_t name  in

        let functionName = self#lower_vhdl_name_t functionName  in

        let const = self#vhdl_constraint_t const  in

        { name; functionName; const }

    method vhdl_discrete_range_t :

      vhdl_discrete_range_t -> vhdl_discrete_range_t=

      fun x  ->

        match x with

        | SubDiscreteRange a ->

            let a = self#vhdl_subtype_indication_t a  in SubDiscreteRange a

        | NamedRange a -> let a = self#lower_vhdl_name_t a  in NamedRange a

        | DirectedRange { direction; from; _to } ->

            let direction = self#string direction  in

            let from = self#vhdl_expr_t from  in

            let _to = self#vhdl_expr_t _to  in

            DirectedRange { direction; from; _to }

    method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t=

      fun x  ->

        match x with

        | RefConstraint { ref_name } ->

            let ref_name = self#lower_vhdl_name_t ref_name  in

            RefConstraint { ref_name }

        | RangeConstraint { range } ->

            let range = self#vhdl_discrete_range_t range  in

            RangeConstraint { range }

        | IndexConstraint { ranges } ->

            let ranges = self#list self#vhdl_discrete_range_t ranges  in

            IndexConstraint { ranges }

        | ArrayConstraint { ranges; sub } ->

            let ranges = self#list self#vhdl_discrete_range_t ranges  in

            let sub = self#vhdl_constraint_t sub  in

            ArrayConstraint { ranges; sub }

        | RecordConstraint  -> RecordConstraint

        | NoConstraint  -> NoConstraint

    method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t=

      fun x  ->

        match x with

        | Type { name; definition } ->

            let name = self#lower_vhdl_name_t name  in

            let definition = self#vhdl_type_t definition  in

            Type { name; definition }

        | Subtype { name; typ } ->

            let name = self#lower_vhdl_name_t name  in

            let typ = self#vhdl_subtype_indication_t typ  in

            Subtype { name; typ }

    method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t=

      fun x  ->

        match x with

        | Call a -> let a = self#lower_vhdl_name_t a  in Call a

        | Cst { value; unit_name } ->

            let value = self#vhdl_cst_val_t value  in

            let unit_name = self#option self#lower_vhdl_name_t unit_name  in

            Cst { value; unit_name }

        | Op { id; args } ->

            let id = self#string id  in

            let args = self#list self#vhdl_expr_t args  in Op { id; args }

        | IsNull  -> IsNull

        | Time { value; phy_unit } ->

            let value = self#int value  in

            let phy_unit = self#string phy_unit  in Time { value; phy_unit }

        | Sig { name; att } ->

            let name = self#lower_vhdl_name_t name  in

            let att = self#option self#vhdl_signal_attributes_t att  in

            Sig { name; att }

        | SuffixMod { expr; selection } ->

            let expr = self#vhdl_expr_t expr  in

            let selection = self#vhdl_suffix_selection_t selection  in

            SuffixMod { expr; selection }

        | Aggregate { elems } ->

            let elems = self#list self#vhdl_element_assoc_t elems  in

            Aggregate { elems }

        | QualifiedExpression { type_mark; aggregate; expression } ->

            let type_mark = self#lower_vhdl_name_t type_mark  in

            let aggregate = self#list self#vhdl_element_assoc_t aggregate  in

            let expression = self#option self#vhdl_expr_t expression  in

            QualifiedExpression { type_mark; aggregate; expression }

        | Others  -> Others

    method vhdl_name_t : vhdl_name_t -> vhdl_name_t=

      fun x  ->

        match x with

        | Simple a -> let a = self#string a  in Simple a

        | Identifier a -> let a = self#string a  in Identifier a

        | Selected a -> let a = self#list self#lower_vhdl_name_t a  in Selected a

        | Index { id; exprs } ->

            let id = self#lower_vhdl_name_t id  in

            let exprs = self#list self#vhdl_expr_t exprs  in

            Index { id; exprs }

        | Slice { id; range } ->

            let id = self#lower_vhdl_name_t id  in

            let range = self#vhdl_discrete_range_t range  in

            Slice { id; range }

        | Attribute { id; designator; expr } ->

            let id = self#lower_vhdl_name_t id  in

            let designator = self#lower_vhdl_name_t designator  in

            let expr = self#vhdl_expr_t expr  in

            Attribute { id; designator; expr }

        | Function { id; assoc_list } ->

            let id = self#lower_vhdl_name_t id  in

            let assoc_list = self#list self#vhdl_assoc_element_t assoc_list

               in

            Function { id; assoc_list }

        | NoName  -> NoName

    method vhdl_assoc_element_t :

      vhdl_assoc_element_t -> vhdl_assoc_element_t=

      fun

        { formal_name; formal_arg; actual_name; actual_designator;

          actual_expr }

         ->

        let formal_name = self#option self#lower_vhdl_name_t formal_name  in

        let formal_arg = self#option self#lower_vhdl_name_t formal_arg  in

        let actual_name = self#option self#lower_vhdl_name_t actual_name  in

        let actual_designator =

          self#option self#lower_vhdl_name_t actual_designator  in

        let actual_expr = self#option self#vhdl_expr_t actual_expr  in

        {

          formal_name;

          formal_arg;

          actual_name;

          actual_designator;

          actual_expr

        }

    method vhdl_element_assoc_t :

      vhdl_element_assoc_t -> vhdl_element_assoc_t=

      fun { choices; expr }  ->

        let choices = self#list self#vhdl_expr_t choices  in

        let expr = self#vhdl_expr_t expr  in { choices; expr }

    method vhdl_array_attributes_t :

      vhdl_array_attributes_t -> vhdl_array_attributes_t=

      fun x  ->

        match x with

        | AAttInt { id; arg } ->

            let id = self#string id  in

            let arg = self#int arg  in AAttInt { id; arg }

        | AAttAscending  -> AAttAscending

    method vhdl_signal_attributes_t :

      vhdl_signal_attributes_t -> vhdl_signal_attributes_t=

      fun x  -> match x with | SigAtt a -> let a = self#string a  in SigAtt a

    method vhdl_string_attributes_t :

      vhdl_string_attributes_t -> vhdl_string_attributes_t=

      fun x  ->

        match x with | StringAtt a -> let a = self#string a  in StringAtt a

    method vhdl_suffix_selection_t : vhdl_suffix_selection_t -> vhdl_suffix_selection_t=

      fun x  ->

        match x with

        | Idx a -> let a = self#int a  in Idx a

        | SuffixRange (a,b) ->

            let a = self#int a  in let b = self#int b  in SuffixRange (a, b)

    method vhdl_type_attributes_t :

      'a .

        ('a -> 'a) -> 'a vhdl_type_attributes_t -> 'a vhdl_type_attributes_t=

      fun _basetype  ->

        fun x  ->

          match x with

          | TAttNoArg { id } -> let id = self#string id  in TAttNoArg { id }

          | TAttIntArg { id; arg } ->

              let id = self#string id  in

              let arg = self#int arg  in TAttIntArg { id; arg }

          | TAttValArg { id; arg } ->

              let id = self#string id  in

              let arg = _basetype arg  in TAttValArg { id; arg }

          | TAttStringArg { id; arg } ->

              let id = self#string id  in

              let arg = self#string arg  in TAttStringArg { id; arg }

    method vhdl_parameter_t : vhdl_parameter_t -> vhdl_parameter_t=

      fun { names; mode; typ; init_val }  ->

        let names = self#list self#lower_vhdl_name_t names  in

        let mode = self#list self#string mode  in

        let typ = self#vhdl_subtype_indication_t typ  in

        let init_val = self#option self#vhdl_cst_val_t init_val  in

        { names; mode; typ; init_val }

    method vhdl_subprogram_spec_t :

      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=

      fun { name; subprogram_type; typeMark; parameters; isPure }  ->

        let name = self#string name  in

        let subprogram_type = self#string subprogram_type  in

        let typeMark = self#lower_vhdl_name_t typeMark  in

        let parameters = self#list self#vhdl_parameter_t parameters  in

        let isPure = self#bool isPure  in

        { name; subprogram_type; typeMark; parameters; isPure }

    method vhdl_sequential_stmt_t :

      vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t=

      fun x  ->

        match x with

        | VarAssign { label; lhs; rhs } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            let lhs = self#lower_vhdl_name_t lhs  in

            let rhs = self#vhdl_expr_t rhs  in VarAssign { label; lhs; rhs }

        | SigSeqAssign { label; lhs; rhs } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            let lhs = self#lower_vhdl_name_t lhs  in

            let rhs = self#list self#vhdl_waveform_element_t rhs in

            SigSeqAssign { label; lhs; rhs }

        | If { label; if_cases; default } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            let if_cases = List.map self#vhdl_if_case_t if_cases  in

            let default = List.map self#vhdl_sequential_stmt_t default  in

            If { label; if_cases; default }

        | Case { label; guard; branches } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            let guard = self#vhdl_expr_t guard  in

            let branches = List.map self#vhdl_case_item_t branches  in

            Case { label; guard; branches }

        | Exit { label; loop_label; condition } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            let loop_label = self#option self#string loop_label  in

            let condition = self#option self#vhdl_expr_t condition  in

            Exit { label; loop_label; condition }

        | Assert { label; cond; report; severity } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            let cond = self#vhdl_expr_t cond  in

            let report = self#vhdl_expr_t report  in

            let severity = self#vhdl_expr_t severity  in

            Assert { label; cond; report; severity }

        | ProcedureCall { label; name; assocs } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            let name = self#lower_vhdl_name_t name  in

            let assocs = self#list self#vhdl_assoc_element_t assocs  in

            ProcedureCall { label; name; assocs }

        | Wait  -> Wait

        | Null { label } ->

            let label = match label with NoName -> None | _ -> Some (self#lower_vhdl_name_t label) in

            Null { label }

        | Return { label; expr } ->

            let label = self#option self#lower_vhdl_name_t label  in

            let expr = self#option self#vhdl_expr_t expr in

            Return { label; expr }

    method vhdl_if_case_t : vhdl_if_case_t -> mini_vhdl_if_case_t=

      fun { if_cond; if_block }  ->

        let if_cond = self#vhdl_expr_t if_cond  in

        let if_block = List.map self#vhdl_sequential_stmt_t if_block  in

        { if_cond; if_block }

    method vhdl_case_item_t : vhdl_case_item_t -> mini_vhdl_case_item_t=

      fun { when_cond; when_stmt }  ->

        let when_cond = self#list self#vhdl_expr_t when_cond  in

        let when_stmt = List.map self#vhdl_sequential_stmt_t when_stmt  in

        { when_cond; when_stmt }

    method vhdl_declaration_t : vhdl_declaration_t -> mini_vhdl_declaration_t=

      fun x  ->

        match x with

        | VarDecl { names; typ; init_val } ->

            let names = self#list self#lower_vhdl_name_t names  in

            let typ = self#vhdl_subtype_indication_t typ  in

            let init_val = self#vhdl_expr_t init_val  in

            VarDecl { names; typ; init_val }

        | CstDecl { names; typ; init_val } ->

            let names = self#list self#lower_vhdl_name_t names  in

            let typ = self#vhdl_subtype_indication_t typ  in

            let init_val = self#vhdl_expr_t init_val  in

            CstDecl { names; typ; init_val }

        | SigDecl { names; typ; init_val } ->

            let names = self#list self#lower_vhdl_name_t names  in

            let typ = self#vhdl_subtype_indication_t typ  in

            let init_val = self#vhdl_expr_t init_val  in

            SigDecl { names; typ; init_val }

        | ComponentDecl { name; generics; ports } ->

            let name = self#lower_vhdl_name_t name  in

            let generics = self#list self#vhdl_port_t generics  in

            let ports = self#list self#vhdl_port_t ports  in

            ComponentDecl { name; generics; ports }

        | Subprogram { spec; decl_part; stmts } ->

            let spec = self#vhdl_subprogram_spec_t spec  in

            let decl_part = List.map self#vhdl_declaration_t decl_part  in

            let stmts = List.map self#vhdl_sequential_stmt_t stmts  in

            Subprogram { spec; decl_part; stmts }

    method vhdl_declarative_item_t :

      vhdl_declarative_item_t -> mini_vhdl_declarative_item_t=

      fun { use_clause; declaration; definition }  ->

        let use_clause = self#option self#vhdl_load_t use_clause  in

        let declaration = 

          match declaration with

          | None -> None

          | Some a -> Some (self#vhdl_declaration_t a) in

        let definition = self#option self#vhdl_definition_t definition  in

        { use_clause; declaration; definition }

    method vhdl_waveform_element_t :

      vhdl_waveform_element_t -> vhdl_waveform_element_t=

      fun { value; delay }  ->

        let value = self#option self#vhdl_expr_t value  in

        let delay = self#option self#vhdl_expr_t delay  in { value; delay }

    method vhdl_signal_condition_t :

      vhdl_signal_condition_t -> vhdl_signal_condition_t=

      fun { expr; cond }  ->

        let expr = self#list self#vhdl_waveform_element_t expr  in

        let cond = self#option self#vhdl_expr_t cond  in { expr; cond }

    method vhdl_signal_selection_t :

      vhdl_signal_selection_t -> vhdl_signal_selection_t=

      fun { expr; when_sel }  ->

        let expr = self#list self#vhdl_waveform_element_t expr  in

        let when_sel = self#list self#vhdl_expr_t when_sel  in

        { expr; when_sel }

    method vhdl_conditional_signal_t :

      vhdl_conditional_signal_t -> vhdl_conditional_signal_t=

      fun { postponed; label; lhs; rhs; delay }  ->

        let postponed = self#bool postponed  in

        let label = self#lower_vhdl_name_t label  in

        let lhs = self#lower_vhdl_name_t lhs  in

        let rhs = self#list self#vhdl_signal_condition_t rhs  in

        let delay = self#vhdl_expr_t delay  in

        { postponed; label; lhs; rhs; delay }

    method vhdl_process_t : vhdl_process_t -> mini_vhdl_process_t=

      fun { id; declarations; active_sigs; body }  ->

        let id = self#lower_vhdl_name_t id  in

        let declarations = List.map self#vhdl_declarative_item_t declarations  in

        let active_sigs = self#list self#lower_vhdl_name_t active_sigs  in

        let body = List.map self#vhdl_sequential_stmt_t body  in

        let postponed = false in

        let label = None in

        { id; declarations; active_sigs; body; postponed; label }

    method vhdl_selected_signal_t :

      vhdl_selected_signal_t -> vhdl_selected_signal_t=

      fun { postponed; label; lhs; sel; branches; delay }  ->

        let postponed = self#bool postponed  in

        let label = self#lower_vhdl_name_t label  in

        let lhs = self#lower_vhdl_name_t lhs  in

        let sel = self#vhdl_expr_t sel  in

        let branches = self#list self#vhdl_signal_selection_t branches  in

        let delay = self#option self#vhdl_expr_t delay  in

        { postponed; label; lhs; sel; branches; delay }

    method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=

      fun x  -> x

    method vhdl_component_instantiation_t :

      vhdl_component_instantiation_t -> mini_vhdl_component_instantiation_t=

        fun { name; inst_unit; inst_unit_type; archi_name; generic_map; port_map }  ->

        let name = self#lower_vhdl_name_t name  in

        let archi_name = self#option self#lower_vhdl_name_t archi_name  in

        let inst_unit = self#lower_vhdl_name_t inst_unit in

        let db_tuple = match archi_name with

          | None -> failwith ("Component [" ^ self#to_string_vhdl_name_t name ^ "] is not an entity")

          | Some a -> self#get_tuple_from_archi_and_entity_name (a, inst_unit) in (* Get corresponding tuple in db *)

        let archi = db_tuple.architecture in

        let entity = db_tuple.entity in

        let generic_map = self#list self#vhdl_assoc_element_t generic_map  in

        let port_map = self#list self#vhdl_assoc_element_t port_map  in

        { name; archi; entity; generic_map; port_map }

    method vhdl_concurrent_stmt_t :

      vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=

      fun x  ->

        match x with

        | SigAssign a -> 

            Process {

              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";

              declarations = [];

              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

              body = (SigCondAssign {

                label = None;

                lhs = a.lhs;

                rhs = a.rhs;

                delay = match a.delay with | IsNull -> None | _ -> Some a.delay

              })::[];

              postponed = a.postponed;

              label = match a.label with | NoName -> None | _ -> Some a.label

            }

        | Process a -> let a = self#vhdl_process_t a  in Process a

        | SelectedSig a -> 

            Process {

              id = self#postfix_flatten_vhdl_name_t a.lhs "__implicit_process";

              declarations = [];

              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

              body = (SigSelectAssign {

                label = None;

                lhs = a.lhs;

                sel = a.sel;

                branches = a.branches;

                delay = a.delay

              })::[];

              postponed = a.postponed;

              label = match a.label with | NoName -> None | _ -> Some a.label

            }

        | ComponentInst a -> let a = self#vhdl_component_instantiation_t a  in ComponentInst a

    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=

      fun { names; mode; typ; expr }  ->

        let names = self#list self#lower_vhdl_name_t names  in

        let mode = self#vhdl_port_mode_t mode  in

        let typ = self#vhdl_subtype_indication_t typ  in

        let expr = self#vhdl_expr_t expr  in { names; mode; typ; expr }

    method vhdl_entity_t : vhdl_entity_t -> unit =

      fun { name; generics; ports; declaration; stmts }  -> ()

    method vhdl_package_t : (vhdl_load_t list * vhdl_package_t) -> mini_vhdl_package_t=

      fun ( ctxs, {name; shared_defs; shared_decls; shared_uses })  ->

        let name = self#lower_vhdl_name_t name  in

        let shared_defs = self#list self#vhdl_definition_t shared_defs  in

        let shared_decls = List.map self#vhdl_declaration_t shared_decls  in

        let shared_uses = self#list self#vhdl_load_t shared_uses @ ctxs in

        { name; shared_defs; shared_decls; shared_uses }

    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=

      fun x  ->

        match x with

        | Library a -> let a = self#list self#lower_vhdl_name_t a  in Library a

        | Use a -> let a = self#list self#lower_vhdl_name_t a  in Use a

    method vhdl_architecture_t : ((vhdl_load_t list * vhdl_package_t) list *

                                  (vhdl_load_t list * vhdl_entity_t) list * 

                                  (vhdl_load_t list * vhdl_configuration_t) list *

                                  (vhdl_load_t list * vhdl_architecture_t)) -> mini_vhdl_component_t=

      fun ( packs_pairs, ents_pairs, confs_pairs, (arch_ctx, arch) ) ->

        let names = arch.name::(arch.entity::[])  in

        let (ref_ent_ctx,ref_ent) = self#filter_entity (ents_pairs, arch.entity) in

        let contexts =

          ref_ent_ctx @ (* Referenced entity context elements *)

          arch_ctx @ (* Architecture context elements *)

          self#declarative_items_uses ref_ent.declaration @ (* Referenced entity inner context elements *)

          self#declarative_items_uses arch.declarations in (* Architecture inner context elements *)

        let declarations = 

          self#declarative_items_declarations ref_ent.declaration @ (* Referenced entity inner declarations *)

          self#declarative_items_declarations arch.declarations in (* Architecture inner declarations *)

        let definitions =

          self#declarative_items_definitions ref_ent.declaration @ (* Referenced entity inner definitions *)

          self#declarative_items_definitions arch.declarations in (* Architecture inner definitions *)

        let body = 

          List.map self#vhdl_concurrent_stmt_t ref_ent.stmts @ (* Referenced entity concurrent statement *)

          List.map self#vhdl_concurrent_stmt_t arch.body in (* Architecture concurrent statements *)

        let generics = ref_ent.generics in (* Referenced entity generics *)

        let ports = ref_ent.ports in (* Referenced entity ports *)

        let declarations = List.map self#vhdl_declaration_t declarations in

        let signals = 

          let rec find_sig_decls declarations = 

            match declarations with

            | [] -> []

            | (SigDecl (s))::tl -> (SigDecl (s))::find_sig_decls tl

            | _::tl -> find_sig_decls tl in find_sig_decls declarations in

        let assigned_names = List.flatten (List.map self#mini_vhdl_concurrent_stmt_t_assigned_signals_names body) in

        (* TODO: Flatten component instantiation from here *)

        self#db_add_tuple { entity=ref_ent; 

                            architecture=arch; 

                            architecture_signals=signals;

                            architecture_ports=ports;

                            architecture_generics=generics;

                            assigned_names=assigned_names;

                            contexts=contexts;

                          };

        { names; 

          generics=generics; 

          ports=ports; 

          contexts=contexts; 

          declarations=declarations; 

          definitions=definitions; 

          body=body

        }

    method vhdl_configuration_t :

      vhdl_configuration_t -> unit= self#unit

    method vhdl_library_unit_t : vhdl_library_unit_t -> unit=

      fun x  -> ()

    method vhdl_design_unit_t : vhdl_design_unit_t -> unit=

      fun { contexts; library }  -> ()

    method vhdl_design_file_t : vhdl_design_file_t -> mini_vhdl_design_file_t=

      fun { design_units }  ->

        let rec inline_df l packs ents archs confs = match l with

          | [] -> (List.rev packs, List.rev ents, List.rev archs, List.rev confs)

          | {contexts = c; library = lib}::tl -> match lib with

            | Package p -> inline_df tl ((c,p)::packs) ents archs confs

            | Entities e -> inline_df tl packs ((c,e)::ents) archs confs

            | Architecture a -> inline_df tl packs ents ((c,a)::archs) confs

            | Configuration conf -> inline_df tl packs ents archs ((c,conf)::confs) in

        let (p,e,a,con) = inline_df design_units [] [] [] [] in

        let app x = self#vhdl_architecture_t (p,e,con,x) in

        let components = List.map app a in

        let packages = List.map self#vhdl_package_t p in

        { components; packages }

  end