CristalCaveGem » LustreC

open Vhdl_ast

open Vhdl_ast_pp

open Mini_vhdl_ast

open Vhdl_2_mini_vhdl_map

open Lustre_types

open Utils

class virtual mini_vhdl_to_lustre_map =

  object (self)

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

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

    method virtual  string : string -> string

    method virtual  int : int -> int

    (*

     * Lustre structure constructors

     *)

    method lustre_mk_var_decl : vhdl_port_mode_t -> vhdl_name_t list -> vhdl_subtype_indication_t -> var_decl list=

      fun mode -> fun names -> fun typ ->

        let var_id_list = List.map show_vhdl_name_t names in

        let var_orig = match mode with InPort -> true | _ -> false in

        let var_dec_type = self#vhdl_subtype_indication_t_type_dec typ in

        let var_dec_clock = {ck_dec_desc = Ckdec_any; ck_dec_loc = Location.dummy_loc } in

        let var_dec_const = false in

        let var_dec_value = None in

        let var_parent_nodeid = None in

        let var_type = self#vhdl_subtype_indication_t typ in

        let var_clock = Clocks.new_ck Cvar false in

        let var_loc = Location.dummy_loc in

        List.map (fun var_id -> {var_id;var_orig;var_dec_type;var_dec_clock;var_dec_const;

                                 var_dec_value;var_parent_nodeid;var_type;var_clock;var_loc}) var_id_list

    method lustre_mk_node : vhdl_name_t list -> var_decl list -> vhdl_port_t list -> mini_vhdl_concurrent_stmt_t list -> top_decl_desc=

      fun names -> fun node_locals -> fun ports -> fun c_stmts ->

        let node_id = String.concat "__" (List.map show_vhdl_name_t names) in

        let node_type = Types.new_var () in

        let node_clock = Clocks.new_ck Cvar false in

        let in_ports = Mini_vhdl_utils.get_ports ports InPort in

        let inports_names = List.map Mini_vhdl_utils.get_names in_ports in

        let inports_types = List.map (fun x -> x.typ) in_ports in

        let node_inputs = List.flatten (List.map2 (self#lustre_mk_var_decl InPort) inports_names inports_types) in

        let out_ports = Mini_vhdl_utils.get_ports ports OutPort in

        let outports_names = List.map Mini_vhdl_utils.get_names out_ports in

        let outports_types = List.map (fun x -> x.typ) out_ports in

        let node_outputs = List.flatten (List.map2 (self#lustre_mk_var_decl OutPort) outports_names outports_types) in

        (* TODO: deal with inout ports *)

        let body = List.map self#mini_vhdl_concurrent_stmt_t c_stmts in

        Node { node_id; node_type; node_clock; 

               node_inputs; node_outputs; node_locals;

               node_gencalls = []; node_checks = []; node_asserts = [];

               node_stmts = body; node_dec_stateless = false; node_stateless = None; 

               node_spec = None; node_annot = [] }

    (*

     * Mini_vhdl to lustre tranformation

     *)

    method vhdl_port_t : vhdl_port_t -> vhdl_port_t= fun x -> x

    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 = 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#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#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 -> Types.type_expr=

      fun { name; functionName; const }  ->

        let name = self#vhdl_name_t name  in

        let functionName = self#vhdl_name_t functionName  in

        let const = self#vhdl_constraint_t const  in

        let desc = match name with

                  | "integer" -> Types.Tbasic (Tint)

                  | "boolean" -> Types.Tbasic (Tbool)

                  | _ -> Tconst (name) in

        Types.new_ty desc;

    method vhdl_subtype_indication_t_type_dec :

      vhdl_subtype_indication_t -> type_dec=

      fun { name; functionName; const }  ->

        let name = self#vhdl_name_t name  in

        let functionName = self#vhdl_name_t functionName  in

        let const = self#vhdl_constraint_t const  in

        {ty_dec_desc = Tydec_const name;

         ty_dec_loc = Location.dummy_loc }

    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#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  ->

        x

(*        match x with

        | RefConstraint { ref_name } ->

            let ref_name = self#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  ->

        x

(*        match x with

        | Type { name; definition } ->

            let name = self#vhdl_name_t name  in

            let definition = self#vhdl_type_t definition  in

            Type { name; definition }

        | Subtype { name; typ } ->

            let name = self#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  ->

        x

(*        match x with

        | Call a -> let a = self#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#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#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#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 -> string=

      fun x  ->

        show_vhdl_name_t x

    method vhdl_assoc_element_t :

      vhdl_assoc_element_t -> vhdl_assoc_element_t=

      fun

        { formal_name; formal_arg; actual_name; actual_designator;

          actual_expr }

        (* At this point of the transformation, association elements have been resolved. 

         * formal_[name|arg] are empty

         * A simple variable name is of the form: actual_designator

         * A function call is of the form: actual_name ( [actual_designator | actual_expr] )

         * A conversion function is of the form: actual_name ( [actual_designator | actual_expr] )

         *)

         ->

(*        let formal_name = self#option self#vhdl_name_t formal_name  in

        let formal_arg = self#option self#vhdl_name_t formal_arg  in

        let actual_name = self#option self#vhdl_name_t actual_name  in

        let actual_designator =

          self#option self#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)

    (* TODO *)

    method mini_vhdl_sequential_stmt_t :

      mini_vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t=

      fun x  ->

        x

(*        match x with

        | VarAssign { label; lhs; rhs } ->

            let label = self#option self#vhdl_name_t label  in 

            let lhs = self#vhdl_name_t lhs  in

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

        | SigSeqAssign { label; lhs; rhs } ->

            let label = self#option self#vhdl_name_t label  in

            let lhs = self#vhdl_name_t lhs  in

            let rhs = self#list self#vhdl_waveform_element_t rhs  in

            SigSeqAssign { label; lhs; rhs }

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

            let label = self#option self#vhdl_name_t label  in

            let lhs = self#vhdl_name_t lhs  in

            let rhs = self#list self#vhdl_signal_condition_t rhs  in

            let delay = self#option self#vhdl_expr_t delay  in

            SigCondAssign { label; lhs; rhs; delay }

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

            let label = self#option self#vhdl_name_t label  in

            let lhs = self#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

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

        | If { label; if_cases; default } ->

            let label = self#option self#vhdl_name_t label  in

            let if_cases = self#list self#mini_vhdl_if_case_t if_cases  in

            let default = self#list self#mini_vhdl_sequential_stmt_t default

               in

            If { label; if_cases; default }

        | Case { label; guard; branches } ->

            let label = self#option self#vhdl_name_t label  in

            let guard = self#vhdl_expr_t guard  in

            let branches = self#list self#mini_vhdl_case_item_t branches  in

            Case { label; guard; branches }

        | Exit { label; loop_label; condition } ->

            let label = self#option self#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 = self#option self#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 = self#option self#vhdl_name_t label  in

            let name = self#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 = self#option self#vhdl_name_t label  in Null { label }

        | Return { label; expr } ->

            let label = self#option self#vhdl_name_t label  in

            let expr = self#option self#vhdl_expr_t expr  in

            Return { label; expr }*)

    method mini_vhdl_if_case_t : mini_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 = self#list self#mini_vhdl_sequential_stmt_t if_block

           in

        { if_cond; if_block }

    method mini_vhdl_case_item_t :

      mini_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 = self#list self#mini_vhdl_sequential_stmt_t when_stmt

           in

        { when_cond; when_stmt }

    method mini_vhdl_declaration_t :

      mini_vhdl_declaration_t -> var_decl list=

      fun x  ->

        match x with

        | VarDecl { names; typ; init_val } ->

            self#lustre_mk_var_decl InPort names typ

(*            let names = self#list self#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 } ->

            self#lustre_mk_var_decl InPort names typ

(*            let names = self#list self#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 } ->

            self#lustre_mk_var_decl InPort names typ

(*            let names = self#list self#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#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 = self#list self#mini_vhdl_declaration_t decl_part

               in

            let stmts = self#list self#mini_vhdl_sequential_stmt_t stmts  in

            Subprogram { spec; decl_part; stmts }*)

    method vhdl_load_t : vhdl_load_t -> vhdl_load_t=

      fun x -> x

    method mini_vhdl_declarative_item_t :

      mini_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 = self#option self#mini_vhdl_declaration_t declaration  in *)

        let definition = self#option self#vhdl_definition_t definition  in

        { use_clause; declaration; definition }

    (* TODO : transform this as a new node *)

    method mini_vhdl_process_t : mini_vhdl_process_t -> mini_vhdl_process_t=

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

(*        let id = self#vhdl_name_t id  in

        let declarations =

          self#list self#mini_vhdl_declarative_item_t declarations  in

        let active_sigs = self#list self#vhdl_name_t active_sigs  in

        let body = self#list self#mini_vhdl_sequential_stmt_t body  in

        let postponed = self#bool postponed  in

        let label = self#option self#vhdl_name_t label  in *)

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

    (* TODO : transform this as a node call *)

    method mini_vhdl_component_instantiation_t :

      mini_vhdl_component_instantiation_t -> statement=

      fun { name; archi; entity; generic_map; port_map }  ->

        let name = self#vhdl_name_t name  in

        let archi = archi  in

        let entity = 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

        Eq {eq_lhs=[name];

            eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";

                    expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};

                    expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};

            eq_loc=Location.dummy_loc}

        (* TODO : Process is a new node; ComponentInst is a node call *)

    method mini_vhdl_concurrent_stmt_t :

      mini_vhdl_concurrent_stmt_t -> statement=

      fun x  ->

        match x with

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

            Eq {eq_lhs=["Process"];

                eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto";

                        expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0};

                        expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc};

                eq_loc=Location.dummy_loc}

        | ComponentInst a ->

            let a = self#mini_vhdl_component_instantiation_t a  in a

    method mini_vhdl_package_t : mini_vhdl_package_t -> top_decl_desc=

      fun { name; shared_defs; shared_decls; shared_uses }  ->

        let node_id = self#vhdl_name_t name  in

        let shared_defs = self#list self#vhdl_definition_t shared_defs  in

        let shared_decls = List.map self#mini_vhdl_declaration_t shared_decls  in

        let shared_uses = self#list self#vhdl_load_t shared_uses in

        let node_type = Types.new_var () in

        let node_clock = Clocks.new_ck Cvar false in

        Node { node_id; node_type; node_clock; 

               node_inputs=[]; node_outputs = []; node_locals = [];

               node_gencalls = []; node_checks = []; node_asserts = [];

               node_stmts = []; node_dec_stateless = false; node_stateless = None; 

               node_spec = None; node_annot = [] }

    method mini_vhdl_component_t :

      mini_vhdl_component_t -> top_decl_desc =

      fun

        { names; generics; ports; contexts; declarations; definitions; body }

         ->

        let generics = self#list self#vhdl_port_t generics  in

        let ports = self#list self#vhdl_port_t ports  in

        let contexts = self#list self#vhdl_load_t contexts  in

        let declarations = List.flatten (List.map self#mini_vhdl_declaration_t declarations) in

        let definitions = List.map self#vhdl_definition_t definitions  in (* TODO: add the result of this transformation to mk_node call *)

        let node_id = String.concat "__" (List.map show_vhdl_name_t names) in

        let node_type = Types.new_var () in

        let node_clock = Clocks.new_ck Cvar false in

        self#lustre_mk_node names declarations ports body

    method mini_vhdl_design_file_t :

      mini_vhdl_design_file_t -> program_t =

      fun { components; packages }  ->

        let components = List.map self#mini_vhdl_component_t components  in

        let packages = List.map self#mini_vhdl_package_t packages  in

        let desc x = { top_decl_desc = x;

		       top_decl_owner = "";

		       top_decl_itf = false;

		       top_decl_loc = Location.dummy_loc } in

        let desc1 = List.map desc components in

        let desc2 = List.map desc packages in

        desc1 @ desc2

  end