/ - Diff - LustreC

« Previous | Next »

Revision d3f0059e

Added by Arnaud Dieumegard about 5 years ago

ID d3f0059eb1584a5f7c847c9492e50746d0304698
Parent 62b6a61c
Child e1102543

New version of the VHDL importer with pretty printing based on ppx_show

     open Vhdl_test
       *)
     open Yojson.Safe
     open Vhdl_ast_utils
     open Vhdl_ast_map
     open Vhdl_ast
     open Ppxlib_traverse_builtins
     open Printf
     let _ =
-...
       (* Create VHDL values *)
       let vhdl = vhdl_file_t_of_yojson vhdl_json in
       (* Simplify VHDL values *)
       match vhdl with
         Ok x ->
           Format.printf "Parsed VHDL: \n%s\n" (pretty_to_string (vhdl_file_t_to_yojson x))
           Format.printf "Parsed VHDL: \n%s\n" (pretty_to_string (vhdl_file_t_to_yojson x));
           let folded = replace_op_expr#vhdl_file_t x in
           Format.printf "PP VHDL: \n%s\n" (show_vhdl_file_t folded);
       | Error e -> Format.printf "Error: %s\n" e;

         CstInt of int
       | CstStdLogic of string
       | CstLiteral of string [@name "CST_LITERAL"]
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     (*
     let pp_cst_val fmt c =
       match c with
       | CstInt i -> Format.fprintf fmt "%i" i
       | CstStdLogic s -> if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
       | CstLiteral s -> Format.fprintf fmt "%s" s
     *)
     type vhdl_type_t =
       | Base of string
-...
       | IsNull [@name "IsNull"]
       | Time of { value: int; phy_unit: string [@default ""]}
       | Sig of { name: vhdl_name_t; att: vhdl_signal_attributes_t option }
       | SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }
       | SuffixMod of { expr : vhdl_expr_t; selection : vhdl_suffix_selection_t }
       | Aggregate of { elems : vhdl_element_assoc_t list } [@name "AGGREGATE"]
       | Others [@name "OTHERS"]
     and vhdl_name_t =
-...
       | AAttAscending
     and vhdl_signal_attributes_t = SigAtt of string
     and vhdl_string_attributes_t = StringAtt of string
     and suffix_selection_t = Idx of int | SuffixRange of int * int
     [@@deriving yojson {strict = false}];;
     and vhdl_suffix_selection_t = Idx of int | SuffixRange of int * int
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     (*
     let rec pp_vhdl_type fmt t =
       match t with
       | Base s -> Format.fprintf fmt "%s" s
       | Range(base, n, m) -> Format.fprintf fmt "%trange %i to %i" (fun fmt -> match base with Some s -> Format.fprintf fmt "%s " s | None -> ()) n m
       | Bit_vector (n,m) -> Format.fprintf fmt "bit_vector(%i downto %i)" n m
       | Array (n, m, base) -> Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
       | Enumerated sl -> Format.fprintf fmt "(%a)" (Utils.fprintf_list ~sep:", " Format.pp_print_string) sl
       | Void -> Format.fprintf fmt ""
     *)
     (************************************************************************************)
     (*            Attributes for types, arrays, signals and strings                     *)
-...
       | TAttIntArg of { id: string; arg: int }
       | TAttValArg of { id: string; arg: 'basetype }
       | TAttStringArg of { id: string; arg: string }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
     let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
-...
         typ: vhdl_subtype_indication_t;
         init_val: cst_val_t option [@default Some (CstInt (0))];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_subprogram_spec_t =
+      {
-...
         parameters: vhdl_parameter_t list;
         isPure: bool [@default false];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     (************************************************************************************)
     (*                        Expressions  / Statements                                 *)
-...
         when_cond: vhdl_expr_t list;
         when_stmt: vhdl_sequential_stmt_t list;
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_declaration_t =
       | VarDecl of {
-...
           decl_part: vhdl_declaration_t list [@default []];
           stmts: vhdl_sequential_stmt_t list [@default []]
         } [@name "SUBPROGRAM_BODY"]
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type signal_condition_t =
     type vhdl_signal_condition_t =
+      {
         expr: vhdl_expr_t list;              (* when expression *)
         cond: vhdl_expr_t [@default IsNull];  (* optional else case expression.
                                                  If None, could be a latch  *)
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type signal_selection_t =
     type vhdl_signal_selection_t =
+      {
         expr : vhdl_expr_t;
         when_sel: vhdl_expr_t list [@default []];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type conditional_signal_t =
     type vhdl_conditional_signal_t =
+      {
         postponed: bool [@default false];
         label: vhdl_name_t [@default NoName];
         lhs: vhdl_name_t;        (* assigned signal = target*)
         rhs: signal_condition_t list;                   (* expression *)
         rhs: vhdl_signal_condition_t list;                   (* expression *)
         cond: vhdl_expr_t [@default IsNull];
         delay: vhdl_expr_t [@default IsNull];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type process_t =
     type vhdl_process_t =
+      {
         id: vhdl_name_t [@default NoName];
         declarations: vhdl_declaration_t list option [@key "PROCESS_DECLARATIVE_PART"] [@default Some []];
         active_sigs: vhdl_name_t list [@default []];
         body: vhdl_sequential_stmt_t list [@key "PROCESS_STATEMENT_PART"] [@default []]
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type selected_signal_t =
     type vhdl_selected_signal_t =
+      {
         postponed: bool [@default false];
         label: vhdl_name_t [@default NoName];
         lhs: vhdl_name_t;      (* assigned signal = target *)
         sel: vhdl_expr_t;
         branches: signal_selection_t list [@default []];
         branches: vhdl_signal_selection_t list [@default []];
         delay: vhdl_expr_t option;
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_concurrent_stmt_t =
       | SigAssign of conditional_signal_t [@name "CONDITIONAL_SIGNAL_ASSIGNMENT"]
       | Process of process_t [@name "PROCESS_STATEMENT"]
       | SelectedSig of selected_signal_t [@name "SELECTED_SIGNAL_ASSIGNMENT"]
     [@@deriving yojson {strict = false}];;
       | SigAssign of vhdl_conditional_signal_t [@name "CONDITIONAL_SIGNAL_ASSIGNMENT"]
       | Process of vhdl_process_t [@name "PROCESS_STATEMENT"]
       | SelectedSig of vhdl_selected_signal_t [@name "SELECTED_SIGNAL_ASSIGNMENT"]
     [@@deriving show { with_path = false }, yojson {strict = false}];;
       (*
     type vhdl_statement_t =
-...
       | OutPort    [@name "out"]
       | InoutPort  [@name "inout"]
       | BufferPort [@name "buffer"]
     [@@deriving yojson];;
     [@@deriving show { with_path = false }, yojson];;
     type vhdl_port_t =
+      {
-...
         typ: vhdl_subtype_indication_t;
         expr: vhdl_expr_t [@default IsNull];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_entity_t =
+      {
-...
         declaration: vhdl_declaration_t list [@key "ENTITY_DECLARATIVE_PART"] [@default []];
         stmts: vhdl_concurrent_stmt_t list [@key "ENTITY_STATEMENT_PART"] [@default []];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     (************************************************************************************)
     (*                    Packages / Library loading                                    *)
-...
         name: vhdl_name_t [@default NoName];
         shared_defs: vhdl_definition_t list [@default []];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_load_t =
         Library of vhdl_name_t list [@name "LIBRARY_CLAUSE"] [@default []]
       | Use of vhdl_name_t list [@name "USE_CLAUSE"] [@default []]
     [@@deriving yojson];;
     [@@deriving show { with_path = false }, yojson];;
     (************************************************************************************)
     (*                        Architecture / VHDL Design                                *)
-...
         declarations: vhdl_declaration_t list [@key "ARCHITECTURE_DECLARATIVE_PART"] [@default []];
         body: vhdl_concurrent_stmt_t list [@key "ARCHITECTURE_STATEMENT_PART"] [@default []];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     (* TODO. Configuration is optional *)
     type vhdl_configuration_t = unit
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_library_unit_t = (* TODO: PACKAGE_BODY *)
         Package of vhdl_package_t [@name "PACKAGE_DECLARATION"]
       | Entities of vhdl_entity_t [@name "ENTITY_DECLARATION"]
       | Architecture of vhdl_architecture_t [@name "ARCHITECTURE_BODY"]
       | Configuration of vhdl_configuration_t [@name "CONFIGURATION_DECLARATION"]
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_design_unit_t =
+      {
         contexts: vhdl_load_t list [@default []];
         library: vhdl_library_unit_t;
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_design_file_t =
+      {
         design_units: vhdl_design_unit_t list [@default []];
+      }
     [@@deriving yojson {strict = false}];;
     [@@deriving show { with_path = false }, yojson {strict = false}];;
     type vhdl_file_t =
+      {
         design_file: vhdl_design_file_t [@default {design_units=[]}] [@key "DESIGN_FILE"];
+      }
     [@@deriving yojson];;
     [@@deriving show { with_path = false }, yojson];;

     open Vhdl_ast
     let _ = fun (_ : cst_val_t)  -> ()
     let _ = fun (_ : vhdl_type_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_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_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)  -> ()
     let _ = fun (_ : vhdl_file_t)  -> ()
     class virtual 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_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_process_t : vhdl_process_t -> vhdl_process_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_declaration_t : vhdl_declaration_t -> vhdl_declaration_t
         method virtual  vhdl_sequential_stmt_t : vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t
         method virtual  vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t
         method virtual  cst_val_t : cst_val_t -> 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_concurrent_stmt_t : vhdl_concurrent_stmt_t -> vhdl_concurrent_stmt_t
         method virtual  vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t
         method virtual  vhdl_architecture_t : vhdl_architecture_t -> vhdl_architecture_t
         method virtual  vhdl_configuration_t : vhdl_configuration_t -> vhdl_configuration_t
         method virtual  vhdl_entity_t : vhdl_entity_t -> vhdl_entity_t
         method virtual  vhdl_package_t : vhdl_package_t -> vhdl_package_t
         method virtual  vhdl_library_unit_t : vhdl_library_unit_t -> vhdl_library_unit_t
         method virtual  vhdl_load_t : vhdl_load_t -> vhdl_load_t
         method virtual  vhdl_design_unit_t : vhdl_design_unit_t -> vhdl_design_unit_t
         method virtual  vhdl_design_file_t : vhdl_design_file_t -> vhdl_design_file_t
         method cst_val_t : cst_val_t -> 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 (a,b,c) ->
                 let a = self#int a  in
                 let b = self#int b  in
                 let c = self#vhdl_type_t c  in Array (a, b, c)
             | Enumerated a -> let a = self#list self#string a  in Enumerated a
             | Void  -> Void
         method vhdl_subtype_indication_t :
           vhdl_subtype_indication_t -> vhdl_subtype_indication_t=
           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
             { 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#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#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#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  ->
             match x with
             | Call a -> let a = self#vhdl_name_t a  in Call a
             | Cst a -> let a = self#cst_val_t a  in Cst a
             | 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 }
             | 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#vhdl_name_t a  in Selected a
             | Index { id; exprs } ->
                 let id = self#vhdl_name_t id  in
                 let exprs = self#list self#vhdl_expr_t exprs  in
                 Index { id; exprs }
             | Slice { id; range } ->
                 let id = self#vhdl_name_t id  in
                 let range = self#vhdl_discrete_range_t range  in
                 Slice { id; range }
             | Attribute { id; designator; expr } ->
                 let id = self#vhdl_name_t id  in
                 let designator = self#vhdl_name_t designator  in
                 let expr = self#vhdl_expr_t expr  in
                 Attribute { id; designator; expr }
             | Function { id; assoc_list } ->
                 let id = self#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#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)
         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#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#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; typeMark; parameters; isPure }  ->
             let name = self#string name  in
             let typeMark = self#vhdl_name_t typeMark  in
             let parameters = self#list self#vhdl_parameter_t parameters  in
             let isPure = self#bool isPure  in
             { name; typeMark; parameters; isPure }
         method vhdl_sequential_stmt_t :
           vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t=
           fun x  ->
             match x with
             | VarAssign { label; lhs; rhs } ->
                 let label = 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#vhdl_name_t label  in
                 let lhs = self#vhdl_name_t lhs  in
                 let rhs = self#list self#vhdl_expr_t rhs  in
                 SigSeqAssign { label; lhs; rhs }
             | If { label; if_cases; default } ->
                 let label = self#vhdl_name_t label  in
                 let if_cases = self#list self#vhdl_if_case_t if_cases  in
                 let default = self#list self#vhdl_sequential_stmt_t default  in
                 If { label; if_cases; default }
             | Case { label; guard; branches } ->
                 let label = self#vhdl_name_t label  in
                 let guard = self#vhdl_expr_t guard  in
                 let branches = self#list self#vhdl_case_item_t branches  in
                 Case { label; guard; branches }
             | Exit { label; loop_label; condition } ->
                 let label = 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#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 }
             | Wait  -> Wait
             | Null { label } ->
                 let label = self#vhdl_name_t label  in Null { label }
             | Return { label } ->
                 let label = self#vhdl_name_t label  in Return { label }
         method vhdl_if_case_t : vhdl_if_case_t -> 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#vhdl_sequential_stmt_t if_block  in
             { if_cond; if_block }
         method vhdl_case_item_t : vhdl_case_item_t -> 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#vhdl_sequential_stmt_t when_stmt  in
             { when_cond; when_stmt }
         method vhdl_declaration_t : vhdl_declaration_t -> vhdl_declaration_t=
           fun x  ->
             match x with
             | VarDecl { names; typ; init_val } ->
                 let names = self#list self#vhdl_name_t names  in
                 let typ = self#vhdl_subtype_indication_t typ  in
                 let init_val = self#option self#cst_val_t init_val  in
                 VarDecl { names; typ; init_val }
             | CstDecl { names; typ; init_val } ->
                 let names = self#list self#vhdl_name_t names  in
                 let typ = self#vhdl_subtype_indication_t typ  in
                 let init_val = self#cst_val_t init_val  in
                 CstDecl { names; typ; init_val }
             | SigDecl { names; typ; init_val } ->
                 let names = self#list self#vhdl_name_t names  in
                 let typ = self#vhdl_subtype_indication_t typ  in
                 let init_val = self#option self#cst_val_t init_val  in
                 SigDecl { names; typ; init_val }
             | Subprogram { name; kind; spec; decl_part; stmts } ->
                 let name = self#vhdl_name_t name  in
                 let kind = self#string kind  in
                 let spec = self#vhdl_subprogram_spec_t spec  in
                 let decl_part = self#list self#vhdl_declaration_t decl_part  in
                 let stmts = self#list self#vhdl_sequential_stmt_t stmts  in
                 Subprogram { name; kind; spec; decl_part; stmts }
         method vhdl_signal_condition_t : vhdl_signal_condition_t -> vhdl_signal_condition_t=
           fun { expr; cond }  ->
             let expr = self#list self#vhdl_expr_t expr  in
             let cond = 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#vhdl_expr_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; cond; delay }  ->
             let postponed = self#bool postponed  in
             let label = 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 cond = self#vhdl_expr_t cond  in
             let delay = self#vhdl_expr_t delay  in
             { postponed; label; lhs; rhs; cond; delay }
         method vhdl_process_t : vhdl_process_t -> vhdl_process_t=
           fun { id; declarations; active_sigs; body }  ->
             let id = self#vhdl_name_t id  in
             let declarations =
               self#option (self#list self#vhdl_declaration_t) declarations  in
             let active_sigs = self#list self#vhdl_name_t active_sigs  in
             let body = self#list self#vhdl_sequential_stmt_t body  in
             { id; declarations; active_sigs; body }
         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#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
             { postponed; label; lhs; sel; branches; delay }
         method vhdl_port_mode_t : vhdl_port_mode_t -> vhdl_port_mode_t=
           fun x  -> x
         method vhdl_concurrent_stmt_t :
           vhdl_concurrent_stmt_t -> vhdl_concurrent_stmt_t=
           fun x  ->
             match x with
             | SigAssign a -> let a = self#vhdl_conditional_signal_t a  in SigAssign a
             | Process a -> let a = self#vhdl_process_t a  in Process a
             | SelectedSig a -> let a = self#vhdl_selected_signal_t a  in SelectedSig a
         method vhdl_port_t : vhdl_port_t -> vhdl_port_t=
           fun { names; mode; typ; expr }  ->
             let names = self#list self#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 -> vhdl_entity_t=
           fun { name; generics; ports; declaration; stmts }  ->
             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
             let declaration = self#list self#vhdl_declaration_t declaration  in
             let stmts = self#list self#vhdl_concurrent_stmt_t stmts  in
             { name; generics; ports; declaration; stmts }
         method vhdl_package_t : vhdl_package_t -> vhdl_package_t=
           fun { name; shared_defs }  ->
             let name = self#vhdl_name_t name  in
             let shared_defs = self#list self#vhdl_definition_t shared_defs  in
             { name; shared_defs }
         method vhdl_load_t : vhdl_load_t -> vhdl_load_t=
           fun x  ->
             match x with
             | Library a -> let a = self#list self#vhdl_name_t a  in Library a
             | Use a -> let a = self#list self#vhdl_name_t a  in Use a
         method vhdl_architecture_t : vhdl_architecture_t -> vhdl_architecture_t=
           fun { name; entity; declarations; body }  ->
             let name = self#vhdl_name_t name  in
             let entity = self#vhdl_name_t entity  in
             let declarations = self#list self#vhdl_declaration_t declarations  in
             let body = self#list self#vhdl_concurrent_stmt_t body  in
             { name; entity; declarations; body }
         method vhdl_configuration_t :
           vhdl_configuration_t -> vhdl_configuration_t= self#unit
         method vhdl_library_unit_t : vhdl_library_unit_t -> vhdl_library_unit_t=
           fun x  ->
             match x with
             | Package a -> let a = self#vhdl_package_t a  in Package a
             | Entities a -> let a = self#vhdl_entity_t a  in Entities a
             | Architecture a ->
                 let a = self#vhdl_architecture_t a  in Architecture a
             | Configuration a ->
                 let a = self#vhdl_configuration_t a  in Configuration a
         method vhdl_design_unit_t : vhdl_design_unit_t -> vhdl_design_unit_t=
           fun { contexts; library }  ->
             let contexts = self#list self#vhdl_load_t contexts  in
             let library = self#vhdl_library_unit_t library  in
             { contexts; library }
         method vhdl_design_file_t : vhdl_design_file_t -> vhdl_design_file_t=
           fun { design_units }  ->
             let design_units = self#list self#vhdl_design_unit_t design_units  in
             { design_units }
         method vhdl_file_t : vhdl_file_t -> vhdl_file_t=
           fun { design_file }  ->
             let design_file = self#vhdl_design_file_t design_file  in
             { design_file }
       end

     open Vhdl_ast_map
     open Vhdl_ast
     open Ppxlib_traverse_builtins
     let any x = x
     let replace_op_expr = object (self)
       inherit Ppxlib_traverse_builtins.map
       inherit vhdl_map as super
       method unit: unit T.map = any
       method vhdl_expr_t = function
         | Op ({id=""; args=hd::[]}) -> self#vhdl_expr_t hd
         | x -> super#vhdl_expr_t x
     end

     open Yojson.Safe
     open Yojson.Safe.Util
     let rec assoc_map_except_str l f str =
       match l with
       | (s,x)::y ->
         if (String.equal s str) then
           assoc_map_except_str y f str
         else
           (s,f str x)::assoc_map_except_str y f str
       | [] -> []
     let rec map_2_args f l arg1 =
       match l with
       | hd::tl -> (f arg1 hd)::(map_2_args f tl arg1)
       | [] -> []
     (*
     Remove `Assoc nodes with tag 'str' in json j
     *)
     let rec prune_str str json =
       match json with
         | `Assoc ((t,hd)::tl) ->
           if (String.equal str t) then
             `Assoc (assoc_map_except_str tl prune_str str)
           else
             `Assoc ((t, prune_str str hd)::(assoc_map_except_str tl prune_str str))
         | `List (hd::tl) -> `List ((prune_str str hd)::(map_2_args prune_str tl str))
         | `String (s) -> if (String.equal str s) then `String ("") else `String (s)
         | x -> x
     (*******************)
     let rec name_pair_list_to_string l =
       match l with
       | (t, `String(x))::tl ->
         if (String.equal t "name") then
           (x::name_pair_list_to_string tl)
         else
           (name_pair_list_to_string tl)
       | _ -> []
     let rec assoc_filter_string l str =
       match l with
       | `Assoc (x) -> name_pair_list_to_string x
       | _ -> []
     (********************)
     let rec pairlist_remove str l f =
       match l with
       | (t,j)::tl ->
         if (String.equal t str) then
           (f j)::(pairlist_remove str tl f)
         else
           `Assoc ((t, f j)::[])::(pairlist_remove str tl f)
       | [] -> []
     (******************)
     let rec assoc_elem_fst pair_list =
       match pair_list with
       | (t,j)::tl -> t::(assoc_elem_fst tl)
       | [] -> []
     let rec assoc_elem_snd pair_list =
       match pair_list with
       | (t,j)::tl -> j::(assoc_elem_snd tl)
       | [] -> []
     let rec assoc_elem_filter pair_list str =
       match pair_list with
       | (t,j)::tl -> if (String.equal t str) then
                         (t,j)::(assoc_elem_filter tl str)
                       else assoc_elem_filter tl str
       | [] -> []
     let rec assoc_elem_filternot pair_list str =
       match pair_list with
       | (t,j)::tl -> if (not (String.equal t str)) then
                         (t,j)::(assoc_elem_filternot tl str)
                       else assoc_elem_filternot tl str
       | [] -> []
     let rec assoc_elem_filter_snd pair_list str =
       match pair_list with
       | (t,j)::tl -> if (String.equal t str) then
                         j::(assoc_elem_filter_snd tl str)
                       else assoc_elem_filter_snd tl str
       | [] -> []
     let rec assoc_elem_filternot_snd pair_list str =
       match pair_list with
       | (t,j)::tl -> if (not (String.equal t str)) then
                         j::(assoc_elem_filter_snd tl str)
                       else assoc_elem_filter_snd tl str
       | [] -> []
     let rec pairlist_snd_as_list pair_list str =
       match pair_list with
       | (t,j)::tl -> if (String.equal t str) then
                         (t,`List (j::[]))::(pairlist_snd_as_list tl str)
                       else (t,j)::(pairlist_snd_as_list tl str)
       | [] -> []
     let all_members str json =
       match json with
       | `Assoc (l) -> assoc_elem_filter_snd l str
       | _ -> []
     let retain_other_members str json =
       match json with
       | `Assoc (l) -> `Assoc (assoc_elem_filter l str)
       | _ -> `Null
     (*
     DESIGN_UNIT as lists
     *)
     let vhdl_json_designunits_content_as_list json =
       let designunits_contents = json |> member "DESIGN_FILE" |> all_members "DESIGN_UNIT" in
       `List designunits_contents
     let vhdl_json_designfile_content_excluding json str =
       json |> member "DESIGN_FILE" |> retain_other_members "DESIGN_UNIT"
     let vhdl_json_list_designunits json =
       let designunits_list = vhdl_json_designunits_content_as_list json in
       `Assoc (("DESIGN_FILE", (`Assoc (("DESIGN_UNIT", designunits_list)::[])))::[])
     let rec pairlist_contains_str str l =
       match l with
       | (t,j)::tl -> if (String.equal t str) then true else pairlist_contains_str str tl
       | [] -> false
     (*
     ITEM element content as list
     *)
     let assoc_elem_as_list str json =
       match json with
       | `Assoc (l) -> `Assoc (pairlist_snd_as_list l str)
       | x -> x
     let rec map_list map_f l f =
       match l with
       | hd::tl -> (map_f (f hd) f)::(map_list map_f tl f)
       | [] -> []
     let rec map_pairlist map_f l f =
       match l with
       | (t,j)::tl -> (t, map_f (f j) f)::(map_pairlist map_f tl f)
       | [] -> []
     let rec map_snd f l =
       match l with
       | (t,j)::tl -> (t,f j)::(map_snd f tl)
       | [] -> []
     let rec map_all json f =
       match json with
       | `Assoc ((t,j)::tl) ->
         `Assoc ((t,(map_all (f j) f))::(map_pairlist map_all tl f))
       | `List (hd::tl) ->
         `List ((map_all (f hd) f)::(map_list map_all tl f))
       | x -> x
     let numeric_literal_simpl json =
       match json with
       | `Assoc (("NUMERIC_LITERAL", `Assoc (("TOKEN", `Assoc (("text", `String(x))::[]))::[]))::[]) -> `String (x)
       | x -> x
     let flatten_numeric_literal json =
       map_all json (numeric_literal_simpl)
     let to_list_str str json =
       map_all json (assoc_elem_as_list str)
     let rec to_list_content_str str json =
       match json with
       | `Assoc (l) -> if (pairlist_contains_str str l) then
           `Assoc (
              (str, to_list_content_str str (`List (assoc_elem_filter_snd l str)))
              ::(assoc_elem_filternot (map_snd (to_list_content_str str) l) str)
+          )
         else
           `Assoc (map_snd (to_list_content_str str) l)
       | `List (hd::tl) -> `List ((to_list_content_str str hd)::(List.map (to_list_content_str str) tl))
       | x -> x
     let rec prune_null_assoc json =
       match json with
       | `Assoc ((t, `Assoc([]))::tl) -> prune_null_assoc (`Assoc tl)
       | `Assoc ((t, `Null)::tl) -> prune_null_assoc (`Assoc tl)
       | `Assoc ((t, j)::tl) -> `Assoc ((t, (prune_null_assoc j))::(map_snd prune_null_assoc tl))
       | `List (`Null::[]) -> `Null
       | `List (l) -> `List (List.map prune_null_assoc l)
       | x -> x
     (*
     Value printers
     *)
     let rec print_depth json depth indent =
       if (depth > 0) then
         match json with
         | `Assoc ((t,j)::tl) ->
           (indent^t)::(List.append (print_depth j (depth-1) (indent^"  "))
                                    (print_depth (`Assoc (tl)) depth indent))
         | `List (hd::tl) ->
           List.append (print_depth hd depth indent)
                       (print_depth (`List (tl)) depth indent)
         | `String (s) -> (indent^s)::[]
         | _ -> []
       else
         []
     let rec flatten_ivd json =
       match json with
       | `Assoc ((t, `List (l))::[]) -> if (String.equal t "INTERFACE_VARIABLE_DECLARATION") then
           `List (List.map flatten_ivd l) else `Assoc ((t, flatten_ivd (`List(l)))::[])
       | `Assoc (l) -> `Assoc (map_snd flatten_ivd l)
       | `List (hd::tl) -> `List((flatten_ivd hd)::(List.map flatten_ivd tl))
       | x -> x
     (*
     let do_stuff json =
       match json with
       | `Assoc ((t,j)::tl) ->
       | `List (hd::tl) ->
       | `String (s) ->
       | _ -> x
     *)

Also available in: Unified diff

Project

General

Profile

CristalCaveGem » LustreC

Revision d3f0059e

Added by Arnaud Dieumegard about 5 years ago