Project

General

Profile

Revision 3d099916

View differences:

src/backends/VHDL/vhdl_ast.ml
146 146
type vhdl_subprogram_spec_t =
147 147
  {
148 148
    name: string [@default ""];
149
    subprogram_type: string [@default ""];
149 150
    typeMark: vhdl_name_t [@default NoName];
150 151
    parameters: vhdl_parameter_t list [@default []];
151 152
    isPure: bool [@default false];
......
223 224
      ports: vhdl_port_t list [@default []];
224 225
    } [@name "COMPONENT_DECLARATION"]
225 226
  | Subprogram of {
226
      name: string [@default ""]; 
227
      kind: string [@default ""]; 
228
      spec: vhdl_subprogram_spec_t option [@default None]; 
227
      spec: vhdl_subprogram_spec_t; 
229 228
      decl_part: vhdl_declaration_t list [@default []]; 
230 229
      stmts: vhdl_sequential_stmt_t list [@default []]
231 230
    } [@name "SUBPROGRAM_BODY"]
src/backends/VHDL/vhdl_ast_deriving.ml
432 432
and show_vhdl_definition_t : vhdl_definition_t -> Ppx_deriving_runtime.string
433 433
  = fun x  -> Format.asprintf "%a" pp_vhdl_definition_t x
434 434

  
435
(* TODO adapt for Op, Time, Sig, suffixMod, Aggregate *)
435
(* TODO adapt for Op, Time, Sig, suffixMod *)
436 436
and pp_vhdl_expr_t :
437 437
  Format.formatter -> vhdl_expr_t -> Ppx_deriving_runtime.unit =
438 438
  let __8 () = pp_vhdl_element_assoc_t
......
2684 2684
type vhdl_subprogram_spec_t =
2685 2685
  {
2686 2686
  name: string [@default ""];
2687
  subprogram_type: string [@default ""];
2687 2688
  typeMark: vhdl_name_t [@default NoName];
2688 2689
  parameters: vhdl_parameter_t list ;
2689 2690
  isPure: bool [@default false]}
......
2698 2699
  ((let open! Ppx_deriving_runtime in
2699 2700
      fun fmt  ->
2700 2701
        fun x  ->
2701
          Format.fprintf fmt "@[<2>{ ";
2702
          ((((Format.fprintf fmt "@[%s =@ " "name";
2703
              (Format.fprintf fmt "%S") x.name;
2704
              Format.fprintf fmt "@]");
2705
             Format.fprintf fmt ";@ ";
2706
             Format.fprintf fmt "@[%s =@ " "typeMark";
2707
             ((__0 ()) fmt) x.typeMark;
2708
             Format.fprintf fmt "@]");
2709
            Format.fprintf fmt ";@ ";
2710
            Format.fprintf fmt "@[%s =@ " "parameters";
2702
          (match x.subprogram_type with
2703
          | "function" -> 
2704
              if (x.isPure) then
2705
                Format.fprintf fmt "pure %s" x.subprogram_type
2706
              else
2707
                Format.fprintf fmt "impure %s" x.subprogram_type
2708
          | "procedure" ->
2709
              Format.fprintf fmt "%s %s" x.subprogram_type x.name);
2710
          (match x.parameters with
2711
          | [] -> Format.fprintf fmt "";
2712
          | _ -> 
2713
            Format.fprintf fmt "(@[";
2711 2714
            ((fun x  ->
2712
                Format.fprintf fmt "@[<2>[";
2713 2715
                ignore
2714 2716
                  (List.fold_left
2715 2717
                     (fun sep  ->
2716 2718
                        fun x  ->
2717
                          if sep then Format.fprintf fmt ";@ ";
2719
                          if sep then Format.fprintf fmt ",@ ";
2718 2720
                          ((__1 ()) fmt) x;
2719
                          true) false x);
2720
                Format.fprintf fmt "@,]@]")) x.parameters;
2721
            Format.fprintf fmt "@]");
2722
           Format.fprintf fmt ";@ ";
2723
           Format.fprintf fmt "@[%s =@ " "isPure";
2724
           (Format.fprintf fmt "%B") x.isPure;
2725
           Format.fprintf fmt "@]");
2726
          Format.fprintf fmt "@ }@]")
2727
    [@ocaml.warning "-A"])
2721
                          true) false x))) x.parameters;
2722
            Format.fprintf fmt "@])");
2723
          (match x.typeMark with
2724
          | NoName -> Format.fprintf fmt "";
2725
          | _ -> 
2726
              Format.fprintf fmt "returns ";
2727
              ((__0 ()) fmt) x.typeMark))
2728
   [@ocaml.warning "-A"])
2728 2729

  
2729 2730
and show_vhdl_subprogram_spec_t :
2730 2731
  vhdl_subprogram_spec_t -> Ppx_deriving_runtime.string =
......
2763 2764
            :: fields
2764 2765
           in
2765 2766
        let fields =
2767
          if x.subprogram_type = ""
2768
          then fields
2769
          else
2770
            ("subprogram_type",
2771
              (((fun (x : Ppx_deriving_runtime.string)  -> `String x))
2772
                 x.subprogram_type))
2773
            :: fields
2774
           in
2775
        let fields =
2766 2776
          if x.name = ""
2767 2777
          then fields
2768 2778
          else
......
2780 2790
  ((let open! Ppx_deriving_yojson_runtime in
2781 2791
      function
2782 2792
      | `Assoc xs ->
2783
          let rec loop xs ((arg0,arg1,arg2,arg3) as _state) =
2793
          let rec loop xs ((arg0,arg1,arg2,arg3,arg4) as _state) =
2784 2794
            match xs with
2785 2795
            | ("name",x)::xs ->
2786 2796
                loop xs
......
2788 2798
                     | `String x -> Result.Ok x
2789 2799
                     | _ ->
2790 2800
                         Result.Error "Vhdl_ast.vhdl_subprogram_spec_t.name")
2791
                      x), arg1, arg2, arg3)
2801
                      x), arg1, arg2, arg3, arg4)
2802
            | ("subprogram_type",x)::xs ->
2803
                loop xs
2804
                  (arg0,
2805
                    ((function
2806
                      | `String x -> Result.Ok x
2807
                      | _ ->
2808
                          Result.Error
2809
                            "Vhdl_ast.vhdl_subprogram_spec_t.subprogram_type")
2810
                       x), arg2, arg3, arg4)
2792 2811
            | ("typeMark",x)::xs ->
2793 2812
                loop xs
2794
                  (arg0, ((fun x  -> vhdl_name_t_of_yojson x) x), arg2, arg3)
2813
                  (arg0, arg1, ((fun x  -> vhdl_name_t_of_yojson x) x), arg3,
2814
                    arg4)
2795 2815
            | ("parameters",x)::xs ->
2796 2816
                loop xs
2797
                  (arg0, arg1,
2817
                  (arg0, arg1, arg2,
2798 2818
                    ((function
2799 2819
                      | `List xs ->
2800 2820
                          map_bind (fun x  -> vhdl_parameter_t_of_yojson x)
......
2802 2822
                      | _ ->
2803 2823
                          Result.Error
2804 2824
                            "Vhdl_ast.vhdl_subprogram_spec_t.parameters") x),
2805
                    arg3)
2825
                    arg4)
2806 2826
            | ("isPure",x)::xs ->
2807 2827
                loop xs
2808
                  (arg0, arg1, arg2,
2828
                  (arg0, arg1, arg2, arg3,
2809 2829
                    ((function
2810 2830
                      | `Bool x -> Result.Ok x
2811 2831
                      | _ ->
2812 2832
                          Result.Error
2813 2833
                            "Vhdl_ast.vhdl_subprogram_spec_t.isPure") x))
2814 2834
            | [] ->
2815
                arg3 >>=
2816
                  ((fun arg3  ->
2817
                      arg2 >>=
2818
                        (fun arg2  ->
2819
                           arg1 >>=
2820
                             (fun arg1  ->
2821
                                arg0 >>=
2822
                                  (fun arg0  ->
2823
                                     Result.Ok
2824
                                       {
2825
                                         name = arg0;
2826
                                         typeMark = arg1;
2827
                                         parameters = arg2;
2828
                                         isPure = arg3
2829
                                       })))))
2835
                arg4 >>=
2836
                  ((fun arg4  ->
2837
                      arg3 >>=
2838
                        (fun arg3  ->
2839
                           arg2 >>=
2840
                             (fun arg2  ->
2841
                                arg1 >>=
2842
                                  (fun arg1  ->
2843
                                     arg0 >>=
2844
                                       (fun arg0  ->
2845
                                          Result.Ok
2846
                                            {
2847
                                              name = arg0;
2848
                                              subprogram_type = arg1;
2849
                                              typeMark = arg2;
2850
                                              parameters = arg3;
2851
                                              isPure = arg4
2852
                                            }))))))
2830 2853
            | _::xs -> loop xs _state  in
2831 2854
          loop xs
2832
            ((Result.Ok ""), (Result.Ok NoName), (Result.Ok []),
2833
              (Result.Ok false))
2855
            ((Result.Ok ""), (Result.Ok ""), (Result.Ok NoName),
2856
              (Result.Ok []), (Result.Ok false))
2834 2857
      | _ -> Result.Error "Vhdl_ast.vhdl_subprogram_spec_t")
2835 2858
  [@ocaml.warning "-A"])
2836 2859

  
......
3025 3048
                                        if sep then Format.fprintf fmt "";
3026 3049
                          ((__8 ()) fmt) x;
3027 3050
                          true) false x))) adefault));
3028
            Format.fprintf fmt "@;end if;@]"
3051
            Format.fprintf fmt "@;end if@]"
3029 3052
        | Case { label = alabel; guard = aguard; branches = abranches } ->
3030 3053
            (match alabel with
3031 3054
              | NoName -> Format.fprintf fmt "";
......
3043 3066
                          if sep then Format.fprintf fmt "";
3044 3067
                          ((__11 ()) fmt) x;
3045 3068
                          true) false x);)) abranches;
3046
            Format.fprintf fmt "@;end case;@]";
3069
            Format.fprintf fmt "@;end case@]";
3047 3070
        | Exit
3048 3071
            { label = alabel; loop_label = aloop_label;
3049 3072
              condition = acondition }
......
4062 4085
  ports: vhdl_port_t list [@default []]} [@name "COMPONENT_DECLARATION"]
4063 4086
  | Subprogram of
4064 4087
  {
4065
  name: string [@default ""];
4066
  kind: string [@default ""];
4067
  spec: vhdl_subprogram_spec_t option [@default None];
4088
  spec: vhdl_subprogram_spec_t ;
4068 4089
  decl_part: vhdl_declaration_t list [@default []];
4069 4090
  stmts: vhdl_sequential_stmt_t list [@default []]} [@name "SUBPROGRAM_BODY"]
4070 4091

  
4071
(* Needs adaptation for: SubProgram *)
4072 4092
let rec pp_vhdl_declaration_t :
4073 4093
  Format.formatter -> vhdl_declaration_t -> Ppx_deriving_runtime.unit =
4074 4094
  let __14 () = pp_vhdl_sequential_stmt_t
......
4176 4196
                        true) false x))) aports;
4177 4197
            Format.fprintf fmt "@]@;end component";
4178 4198
        | Subprogram
4179
            { name = aname; kind = akind; spec = aspec;
4180
              decl_part = adecl_part; stmts = astmts }
4199
            { spec = aspec; decl_part = adecl_part; stmts = astmts }
4181 4200
            ->
4182
            (Format.fprintf fmt "@[<2>Subprogram {@,";
4183
             (((((Format.fprintf fmt "@[%s =@ " "name";
4184
                  (Format.fprintf fmt "%S") aname;
4185
                  Format.fprintf fmt "@]");
4186
                 Format.fprintf fmt ";@ ";
4187
                 Format.fprintf fmt "@[%s =@ " "kind";
4188
                 (Format.fprintf fmt "%S") akind;
4189
                 Format.fprintf fmt "@]");
4190
                Format.fprintf fmt ";@ ";
4191
                Format.fprintf fmt "@[%s =@ " "spec";
4192
                ((function
4193
                  | None  -> Format.pp_print_string fmt "None"
4194
                  | Some x ->
4195
                      (Format.pp_print_string fmt "(Some ";
4196
                       ((__12 ()) fmt) x;
4197
                       Format.pp_print_string fmt ")"))) aspec;
4198
                Format.fprintf fmt "@]");
4199
               Format.fprintf fmt ";@ ";
4200
               Format.fprintf fmt "@[%s =@ " "decl_part";
4201
               ((fun x  ->
4202
                   Format.fprintf fmt "@[<2>[";
4203
                   ignore
4204
                     (List.fold_left
4205
                        (fun sep  ->
4206
                           fun x  ->
4207
                             if sep then Format.fprintf fmt ";@ ";
4201
              Format.fprintf fmt "@[<v 2>";
4202
              ((__12 ()) fmt) aspec;
4203
              Format.fprintf fmt " is";
4204
              (match adecl_part with
4205
              | [] -> Format.fprintf fmt "";
4206
              | _ ->
4207
                ((fun x  ->
4208
                  ignore
4209
                    (List.fold_left
4210
                      (fun sep  ->
4211
                         fun x  ->
4212
                           if sep then Format.fprintf fmt "";
4213
                             Format.fprintf fmt "@;";
4208 4214
                             ((__13 ()) fmt) x;
4209
                             true) false x);
4210
                   Format.fprintf fmt "@,]@]")) adecl_part;
4211
               Format.fprintf fmt "@]");
4212
              Format.fprintf fmt ";@ ";
4213
              Format.fprintf fmt "@[%s =@ " "stmts";
4215
                             Format.fprintf fmt ";";
4216
                             true) false x))) adecl_part);
4217
              Format.fprintf fmt "@]@;";
4218
              Format.fprintf fmt "@[<v 2>begin@;";
4214 4219
              ((fun x  ->
4215
                  Format.fprintf fmt "@[<2>[";
4216 4220
                  ignore
4217 4221
                    (List.fold_left
4218 4222
                       (fun sep  ->
4219 4223
                          fun x  ->
4220
                            if sep then Format.fprintf fmt ";@ ";
4224
                            if sep then Format.fprintf fmt "@;";
4221 4225
                            ((__14 ()) fmt) x;
4222
                            true) false x);
4223
                  Format.fprintf fmt "@,]@]")) astmts;
4224
              Format.fprintf fmt "@]");
4225
             Format.fprintf fmt "@]}"))
4226
                            Format.fprintf fmt ";";
4227
                            true) false x))) astmts;
4228
              Format.fprintf fmt "@]@;end";)
4226 4229
    [@ocaml.warning "-A"])
4227 4230

  
4228 4231
and show_vhdl_declaration_t :
......
4362 4365
                 :: fields
4363 4366
                in
4364 4367
             let fields =
4365
               if arg0.spec = None
4366
               then fields
4367
               else
4368
                 ("spec",
4369
                   (((function
4370
                      | None  -> `Null
4371
                      | Some x ->
4372
                          ((fun x  -> vhdl_subprogram_spec_t_to_yojson x)) x))
4373
                      arg0.spec))
4374
                 :: fields
4375
                in
4376
             let fields =
4377
               if arg0.kind = ""
4378
               then fields
4379
               else
4380
                 ("kind",
4381
                   (((fun (x : Ppx_deriving_runtime.string)  -> `String x))
4382
                      arg0.kind))
4383
                 :: fields
4384
                in
4385
             let fields =
4386
               if arg0.name = ""
4387
               then fields
4388
               else
4389
                 ("name",
4390
                   (((fun (x : Ppx_deriving_runtime.string)  -> `String x))
4391
                      arg0.name))
4392
                 :: fields
4393
                in
4368
               ("spec",
4369
                 ((fun x  -> vhdl_subprogram_spec_t_to_yojson x) arg0.spec))
4370
               :: fields  in
4394 4371
             `Assoc fields)])
4395 4372
  [@ocaml.warning "-A"])
4396 4373

  
......
4578 4555
      | `List ((`String "SUBPROGRAM_BODY")::arg0::[]) ->
4579 4556
          ((function
4580 4557
            | `Assoc xs ->
4581
                let rec loop xs ((arg0,arg1,arg2,arg3,arg4) as _state) =
4558
                let rec loop xs ((arg0,arg1,arg2) as _state) =
4582 4559
                  match xs with
4583
                  | ("name",x)::xs ->
4584
                      loop xs
4585
                        (((function
4586
                           | `String x -> Result.Ok x
4587
                           | _ ->
4588
                               Result.Error
4589
                                 "Vhdl_ast.vhdl_declaration_t.name") x),
4590
                          arg1, arg2, arg3, arg4)
4591
                  | ("kind",x)::xs ->
4592
                      loop xs
4593
                        (arg0,
4594
                          ((function
4595
                            | `String x -> Result.Ok x
4596
                            | _ ->
4597
                                Result.Error
4598
                                  "Vhdl_ast.vhdl_declaration_t.kind") x),
4599
                          arg2, arg3, arg4)
4600 4560
                  | ("spec",x)::xs ->
4601 4561
                      loop xs
4602
                        (arg0, arg1,
4603
                          ((function
4604
                            | `Null -> Result.Ok None
4605
                            | x ->
4606
                                ((fun x  ->
4607
                                    vhdl_subprogram_spec_t_of_yojson x) x)
4608
                                  >>= ((fun x  -> Result.Ok (Some x)))) x),
4609
                          arg3, arg4)
4562
                        (((fun x  -> vhdl_subprogram_spec_t_of_yojson x) x),
4563
                          arg1, arg2)
4610 4564
                  | ("decl_part",x)::xs ->
4611 4565
                      loop xs
4612
                        (arg0, arg1, arg2,
4566
                        (arg0,
4613 4567
                          ((function
4614 4568
                            | `List xs ->
4615 4569
                                map_bind
......
4618 4572
                            | _ ->
4619 4573
                                Result.Error
4620 4574
                                  "Vhdl_ast.vhdl_declaration_t.decl_part") x),
4621
                          arg4)
4575
                          arg2)
4622 4576
                  | ("stmts",x)::xs ->
4623 4577
                      loop xs
4624
                        (arg0, arg1, arg2, arg3,
4578
                        (arg0, arg1,
4625 4579
                          ((function
4626 4580
                            | `List xs ->
4627 4581
                                map_bind
......
4632 4586
                                Result.Error
4633 4587
                                  "Vhdl_ast.vhdl_declaration_t.stmts") x))
4634 4588
                  | [] ->
4635
                      arg4 >>=
4636
                        ((fun arg4  ->
4637
                            arg3 >>=
4638
                              (fun arg3  ->
4639
                                 arg2 >>=
4640
                                   (fun arg2  ->
4641
                                      arg1 >>=
4642
                                        (fun arg1  ->
4643
                                           arg0 >>=
4644
                                             (fun arg0  ->
4645
                                                Result.Ok
4646
                                                  (Subprogram
4647
                                                     {
4648
                                                       name = arg0;
4649
                                                       kind = arg1;
4650
                                                       spec = arg2;
4651
                                                       decl_part = arg3;
4652
                                                       stmts = arg4
4653
                                                     })))))))
4589
                      arg2 >>=
4590
                        ((fun arg2  ->
4591
                            arg1 >>=
4592
                              (fun arg1  ->
4593
                                 arg0 >>=
4594
                                   (fun arg0  ->
4595
                                      Result.Ok
4596
                                        (Subprogram
4597
                                           {
4598
                                             spec = arg0;
4599
                                             decl_part = arg1;
4600
                                             stmts = arg2
4601
                                           })))))
4654 4602
                  | _::xs -> loop xs _state  in
4655 4603
                loop xs
4656
                  ((Result.Ok ""), (Result.Ok ""), (Result.Ok None),
4604
                  ((Result.Error "Vhdl_ast.vhdl_declaration_t.spec"),
4657 4605
                    (Result.Ok []), (Result.Ok []))
4658 4606
            | _ -> Result.Error "Vhdl_ast.vhdl_declaration_t")) arg0
4659 4607
      | _ -> Result.Error "Vhdl_ast.vhdl_declaration_t")
src/backends/VHDL/vhdl_ast_map.ml
289 289

  
290 290
    method vhdl_subprogram_spec_t :
291 291
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
292
      fun { name; typeMark; parameters; isPure }  ->
292
      fun { name; subprogram_type; typeMark; parameters; isPure }  ->
293 293
        let name = self#string name  in
294
        let subprogram_type = self#string subprogram_type  in
294 295
        let typeMark = self#vhdl_name_t typeMark  in
295 296
        let parameters = self#list self#vhdl_parameter_t parameters  in
296 297
        let isPure = self#bool isPure  in
297
        { name; typeMark; parameters; isPure }
298
        { name; subprogram_type; typeMark; parameters; isPure }
298 299

  
299 300
    method vhdl_sequential_stmt_t :
300 301
      vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t=
......
374 375
            let generics = self#list self#vhdl_port_t generics  in
375 376
            let ports = self#list self#vhdl_port_t ports  in
376 377
            ComponentDecl { name; generics; ports }
377
        | Subprogram { name; kind; spec; decl_part; stmts } ->
378
            let name = self#string name  in
379
            let kind = self#string kind  in
380
            let spec = self#option self#vhdl_subprogram_spec_t spec  in
378
        | Subprogram { spec; decl_part; stmts } ->
379
            let spec = self#vhdl_subprogram_spec_t spec  in
381 380
            let decl_part = self#list self#vhdl_declaration_t decl_part  in
382 381
            let stmts = self#list self#vhdl_sequential_stmt_t stmts  in
383
            Subprogram { name; kind; spec; decl_part; stmts }
382
            Subprogram { spec; decl_part; stmts }
384 383

  
385 384
    method vhdl_declarative_item_t :
386 385
      vhdl_declarative_item_t -> vhdl_declarative_item_t=
src/tools/importer/vhdl_to_lustre.ml
291 291

  
292 292
    method vhdl_subprogram_spec_t :
293 293
      vhdl_subprogram_spec_t -> vhdl_subprogram_spec_t=
294
      fun { name; typeMark; parameters; isPure }  ->
294
      fun { name; subprogram_type; typeMark; parameters; isPure }  ->
295 295
        let name = self#string name  in
296
        let subprogram_type = self#string subprogram_type  in
296 297
        let typeMark = self#vhdl_name_t typeMark  in
297 298
        let parameters = self#list self#vhdl_parameter_t parameters  in
298 299
        let isPure = self#bool isPure  in
299
        { name; typeMark; parameters; isPure }
300
        { name; subprogram_type; typeMark; parameters; isPure }
300 301

  
301 302
    method vhdl_sequential_stmt_t :
302 303
      vhdl_sequential_stmt_t -> vhdl_sequential_stmt_t=
......
376 377
            let generics = self#list self#vhdl_port_t generics  in
377 378
            let ports = self#list self#vhdl_port_t ports  in
378 379
            ComponentDecl { name; generics; ports }
379
        | Subprogram { name; kind; spec; decl_part; stmts } ->
380
            let name = self#string name  in
381
            let kind = self#string kind  in
382
            let spec = self#option self#vhdl_subprogram_spec_t spec  in
380
        | Subprogram { spec; decl_part; stmts } ->
381
            let spec = self#vhdl_subprogram_spec_t spec  in
383 382
            let decl_part = self#list self#vhdl_declaration_t decl_part  in
384 383
            let stmts = self#list self#vhdl_sequential_stmt_t stmts  in
385
            Subprogram { name; kind; spec; decl_part; stmts }
384
            Subprogram { spec; decl_part; stmts }
386 385

  
387 386
    method vhdl_declarative_item_t :
388 387
      vhdl_declarative_item_t -> vhdl_declarative_item_t=

Also available in: Unified diff