CristalCaveGem » LustreC

open Vhdl_ast

type mini_vhdl_sequential_stmt_t = 

      label: vhdl_name_t option;

      lhs: vhdl_name_t;

      rhs: vhdl_expr_t }

      label: vhdl_name_t option;

      lhs: vhdl_name_t;

      rhs: vhdl_waveform_element_t list}

      label: vhdl_name_t option;

      lhs: vhdl_name_t;

      rhs: vhdl_signal_condition_t list;

      delay: vhdl_expr_t option}

      label: vhdl_name_t option;

      lhs: vhdl_name_t;

      sel: vhdl_expr_t;

      branches: vhdl_signal_selection_t list;

      delay: vhdl_expr_t option}

      label: vhdl_name_t option;

      if_cases: mini_vhdl_if_case_t list;

      default: mini_vhdl_sequential_stmt_t list}

      label: vhdl_name_t option;

      guard: vhdl_expr_t;

      branches: mini_vhdl_case_item_t list }

      label: vhdl_name_t option;

      loop_label: string option;

      condition: vhdl_expr_t option}

      label: vhdl_name_t option;

      cond: vhdl_expr_t;

      report: vhdl_expr_t;

      severity: vhdl_expr_t}

      label: vhdl_name_t option;

      name: vhdl_name_t;

      assocs: vhdl_assoc_element_t list }

      label: vhdl_name_t option}

     label: vhdl_name_t option;

     expr: vhdl_expr_t option}

and mini_vhdl_if_case_t =

  }

and mini_vhdl_declaration_t =

      names : vhdl_name_t list;

      typ : vhdl_subtype_indication_t;

      init_val : vhdl_expr_t

    }

      names : vhdl_name_t list;

      typ : vhdl_subtype_indication_t;

      init_val : vhdl_expr_t

    }

      names : vhdl_name_t list;

      typ : vhdl_subtype_indication_t;

      init_val : vhdl_expr_t

    }

      name: vhdl_name_t;

      generics: vhdl_port_t list;

      ports: vhdl_port_t list;

    }

      spec: vhdl_subprogram_spec_t;

      decl_part: mini_vhdl_declaration_t list;

      stmts: mini_vhdl_sequential_stmt_t list

  }

and mini_vhdl_concurrent_stmt_t =

and mini_vhdl_package_t =

  {

    packages: mini_vhdl_package_t list;

  }

(*[@@deriving show { with_path = false }]*)

  ((let open! Ppx_deriving_runtime in

      fun fmt  ->

        function

            (match alabel with

              | None -> Format.fprintf fmt "";

              | Some e -> (((__0 ()) fmt) e;

            ((__1 ()) fmt) alhs;

            Format.fprintf fmt " := ";

            ((__2 ()) fmt) arhs;

            (match alabel with

              | None -> Format.fprintf fmt "";

              | Some e -> (((__3 ()) fmt) e;

                        ((__5 ()) fmt) x;

                        true) false x);

            Format.fprintf fmt "@]@]")) arhs;

            (match alabel with

              | None -> Format.fprintf fmt "";

              | Some e -> (((__6 ()) fmt) e;

                        ((__8 ()) fmt) x;

                        true) false x);

            Format.fprintf fmt "@]@]")) arhs;

            { label = alabel; lhs = alhs; sel = asel; branches = abranches;

              delay = adelay }

            ->

                        ((__13 ()) fmt) x;

                        true) false x))) abranches;

            Format.fprintf fmt ";@]"

            (match alabel with

              | None -> Format.fprintf fmt "";

              | Some e -> (((__15 ()) fmt) e;

                          Format.fprintf fmt ";";

                          true) false x))) adefault));

            Format.fprintf fmt "@;end if@]"

            (match alabel with

              | None -> Format.fprintf fmt "";

              | Some e -> (((__18 ()) fmt) e;

                          ((__20 ()) fmt) x;

                          true) false x);)) abranches;

            Format.fprintf fmt "@;end case@]";

            { label = alabel; loop_label = aloop_label;

              condition = acondition }

            ->

               | Some x ->

                   (Format.pp_print_string fmt "when@ ";

                    ((__22 ()) fmt) x;))) acondition;

            { label = alabel; cond = acond; report = areport;

              severity = aseverity }

            ->

                Format.fprintf fmt "@;severity ";

                ((__26 ()) fmt) aseverity);

            Format.fprintf fmt "@]";

            (match alabel with

              | None -> Format.fprintf fmt "";

              | Some e -> (((__27 ()) fmt) e;

                          ((__29 ()) fmt) x;

                          true) false x))) aassocs;

               Format.fprintf fmt "@])");

            (match alabel with

              | None -> Format.fprintf fmt "";

              | Some e -> (((__27 ()) fmt) e;

                     Format.fprintf fmt ":@ ")

            );

            Format.fprintf fmt "null";

            (match alabel with

              | None -> ();

              | Some a -> (((__28 ()) fmt) a;

  ((let open! Ppx_deriving_runtime in

      fun fmt  ->

        function

            (Format.fprintf fmt "variable ";

             ((((fun x  ->

                    ignore

                | _ ->

                    (Format.fprintf fmt ":=";

                     ((__2 ()) fmt) ainit_val;))));)

            (Format.fprintf fmt "constant ";

             ((((fun x  ->

                    ignore

              ((__4 ()) fmt) atyp;

              Format.fprintf fmt " := ";

              ((__5 ()) fmt) ainit_val)))

            (Format.fprintf fmt "signal ";

            ((fun x  ->

              ignore

              | _ ->

                  (Format.fprintf fmt ":=";

                  ((__8 ()) fmt) ainit_val;)))

            { name = aname; generics = agenerics; ports = aports } ->

            Format.fprintf fmt "@[<v 2>component ";

            ((__9 ()) fmt) aname;

                            true) false x))) aports;

                Format.fprintf fmt "@]);");

            Format.fprintf fmt "@]@;end component";

            { spec = aspec; decl_part = adecl_part; stmts = astmts }

            ->

              Format.fprintf fmt "@[<v 2>";

  ((let open! Ppx_deriving_runtime in

      fun fmt  ->

        function

             ((__0 ()) fmt) a0;

             ((__1 ()) fmt) a0;

    )

    [@ocaml.warning "-A"])

let mini_vhdl_declaration_t_names decl=

  match decl with

  | _ -> []

let rec remove_opt l=

    method mini_vhdl_concurrent_stmt_t_assigned_signals_names : mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=

      fun x ->

        match x with

            List.flatten (List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names a.p_body)

          )

            let out_ports_positions = get_ports_pos a.entity.ports OutPort 0 in

            let inout_ports_positions = get_ports_pos a.entity.ports InoutPort 0 in

            let assigned_out_ports_names = List.map (fun x -> x.actual_designator) a.port_map in

      mini_vhdl_sequential_stmt_t -> vhdl_name_t list=

      fun x  ->

        match x with

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

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

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

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

        | _ -> []

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

    method mini_vhdl_concurrent_stmt_t_memories : vhdl_name_t list -> mini_vhdl_concurrent_stmt_t -> vhdl_name_t list=

      fun assigned_signals -> fun x ->

        match x with

    method memories: vhdl_name_t list -> vhdl_name_t list -> mini_vhdl_sequential_stmt_t -> vhdl_name_t list=

      fun assigned_signals -> fun mems -> fun x ->

        match x with

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

            let if_cases_assigned_signals = 

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

            (match default with

              | [] -> (List.flatten if_cases_assigned_signals)@mems

              | _ -> mems)

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

         (*   let case_assigned_signals = List.map self#mini_vhdl_sequential_stmt_t_assigned_signals_names (List.flatten (case_branches_stmts)) in *)

            let cases_memories = List.flatten (List.map (fun x -> List.flatten (List.map (self#memories assigned_signals []) x)) (case_branches_stmts)) in

        | VarAssign { label; seqs_lhs; rhs } ->

            let label = self#option self#lower_vhdl_name_t label in

            let lhs = self#lower_vhdl_name_t seqs_lhs  in

        | SigSeqAssign { label; seqs_lhs; rhs } ->

            let label = self#option self#lower_vhdl_name_t label in

            let lhs = self#lower_vhdl_name_t seqs_lhs  in

            let rhs = self#list self#vhdl_waveform_element_t rhs in

        | If { label; if_cases; default } ->

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

        | Case { label; guard; branches } ->

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

        | Exit { label; loop_label; condition } ->

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

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

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

        | ProcedureCall { label; name; assocs } ->

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

            (* TODO: get procedure declaration and map assoc_elements *)

        | Null { label } ->

            let label = self#option self#lower_vhdl_name_t label in

        | Return { label; expr } ->

            let label = self#option self#lower_vhdl_name_t label  in

            let expr = self#option self#vhdl_expr_t expr in

    method vhdl_if_case_t : vhdl_if_case_t -> mini_vhdl_if_case_t=

      fun { if_cond; if_block }  ->

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

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

            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

        | 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

        | 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

            (* TODO: Explicit memories *)

    method vhdl_declarative_item_t :

      vhdl_declarative_item_t -> mini_vhdl_declarative_item_t=

      fun x  ->

        match x with

        | SigAssign a -> 

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

              p_declarations = [];

              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

                label = None;

                lhs = a.cs_lhs;

                rhs = a.rhs;

              postponed = a.cs_postponed;

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

            }

        | SelectedSig a -> 

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

              p_declarations = [];

              active_sigs = get_sensitivity_list#vhdl_concurrent_stmt_t x [];

                label = None;

                lhs = a.ss_lhs;

                sel = a.sel;

              postponed = a.ss_postponed;

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

            }

    method vhdl_port_t : vhdl_port_t -> vhdl_port_t=

      fun { port_names; port_mode; port_typ; port_expr }  ->

          let rec find_decls c_declarations acc_s acc_p = 

            match c_declarations with

            | [] -> (acc_s, acc_p)

            | _::tl -> find_decls tl acc_s acc_p in find_decls c_declarations [] [] in

        let assigned_signals_names = List.flatten (List.map self#mini_vhdl_concurrent_stmt_t_assigned_signals_names c_body) in

        let functions = List.map (

        ) subprograms in

        let memories = List.flatten (List.map (self#mini_vhdl_concurrent_stmt_t_memories assigned_signals_names) c_body) in

        let new_tuple = { entity=ref_ent; 

      mini_vhdl_declaration_t -> var_decl list=

      fun x  ->

        match x with

            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 }*)

            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 }*)

            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 }*)

            []

(*            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 }*)

            []

(*            let spec = self#vhdl_subprogram_spec_t spec  in

            let decl_part = self#list self#mini_vhdl_declaration_t decl_part

      mini_vhdl_concurrent_stmt_t -> statement=

      fun x  ->

        match x with

            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}

            let a = self#mini_vhdl_component_instantiation_t a  in a

    method mini_vhdl_package_t : mini_vhdl_package_t -> top_decl_desc=