CristalCaveGem » LustreC

(************************************************************************************)		   

(*                       Types                                                      *)

(************************************************************************************)		   

let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ]

  | Base of string

  | Bit_vector of int * int			  

  | Array of int * int * vhdl_type_t 

let rec pp_vhdl_type fmt t =

  | 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

  | Array (n, m, base) -> Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base

(************************************************************************************)		   

(*                     Constants                                                    *)

(************************************************************************************)		   

(* Std_logic values :

    'U': uninitialized. This signal hasn't been set yet.

    'X': unknown. Impossible to determine this value/result.

    '0': logic 0

    '1': logic 1

    'Z': High Impedance

    'W': Weak signal, can't tell if it should be 0 or 1.

    'L': Weak signal that should probably go to 0

    'H': Weak signal that should probably go to 1

    '-': Don't care. *)			       

let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]

(* TODO: do we need more constructors ? *)

type cst_val_t = CstInt of int | CstStdLogic of string

  | CstStdLogic s -> if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false

(************************************************************************************)		   

(*                     Declarations                                                 *)

(************************************************************************************)		   

(* TODO ? Shall we merge definition / declaration  *)

type vhdl_definition_t =

  | Type of {name : string ; definition: vhdl_type_t}

  | Subtype of {name : string ; definition: vhdl_type_t}

let pp_vhdl_definition fmt def =

  match def with

  | Type s -> Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition

  | Subtype s -> Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition

		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())

		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())

(************************************************************************************)		   

(*                        Expressions  / Statements                                 *)

(************************************************************************************)		   

(* TODO: call to functions? procedures? *)  

  | Var of string (* a signal or a variable *)

  | Op of { id: string; args: vhdl_expr_t list } 

let rec pp_vhdl_expr fmt e =

  match e with

  | Var s -> Format.fprintf fmt "%s" s

  | Op op -> (

    match op.args with

    | [] -> assert false

    | _ -> Format.fprintf fmt "%s (%a)" op.id (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args

  )

type vhdl_sequential_stmt_t = 

  | VarAssign of { lhs: string; rhs: vhdl_expr_t }

(*  | Case of { guard: vhdl_expr_t; branches: { case: }

let pp_vhdl_sequential_stmt fmt stmt =

  match stmt with

  | VarAssign va -> Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs

type signal_condition_t =

  {                            

    expr: vhdl_expr_t;              (* when expression *)

    else_case: vhdl_expr_t option;  (* optional else case expression. 

                                             If None, could be a latch  *)

  }

type signal_selection_t =

  {

    sel_lhs: string;

    expr : vhdl_expr_t;

    when_sel: vhdl_expr_t option;

  }

type conditional_signal_t =

  {

      lhs: string;                        (* assigned signal *)

      rhs: vhdl_expr_t;                   (* expression *)

      cond: signal_condition_t option     (* conditional signal statement *)

  }

type process_t =

  { id: string option; active_sigs: string list; body: vhdl_sequential_stmt_t list }

type selected_signal_t = { sel: vhdl_expr_t;  branches: signal_selection_t list }

  | SigAssign of conditional_signal_t 

  | Process of process_t 

  | SelectedSig of selected_signal_t

  (*

   *)

let pp_vhdl_concurrent_stmt fmt stmt =

  let pp_sig_cond fmt va = 

    Format.fprintf

      fmt

      "%s <= %a%t;"

      va.lhs

      pp_vhdl_expr va.rhs

      (fun fmt -> match va.cond with

		  | None -> ()

		  | Some cond ->

		     Format.fprintf

		       fmt

		       " when %a%t"

		       pp_vhdl_expr cond.expr

		       (fun fmt -> match cond.else_case with

				   | None -> ()

				   | Some else_case ->

				      Format.fprintf

					fmt

					" else %a"

					pp_vhdl_expr else_case

		       )

      )

  in

  let pp_process fmt p =

    Format.fprintf

      fmt

      "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"

      (fun fmt -> match p.id with Some id -> Format.fprintf fmt "%s: " id| None -> ())

      (fun fmt asigs ->

       if asigs <> [] then

	 Format.fprintf

	   fmt

	   "(@[<hov 0>%a)@]"

	   (Utils.fprintf_list ~sep:",@ " Format.pp_print_string) asigs)

      p.active_sigs

      (Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt) p.body

  in

  let pp_sig_sel fmt va =

    Format.fprintf fmt "@[<v 3>with %a select@ %a;@]"

		   pp_vhdl_expr va.sel

		   (Utils.fprintf_list

		      ~sep:"@ "

		      (fun fmt b ->

		       Format.fprintf

			 fmt

			 "%s <= %a when %t"

			 b.sel_lhs

			 pp_vhdl_expr b.expr

			 (fun fmt -> match b.when_sel with

				     | None -> Format.fprintf fmt "others"

				     | Some w -> pp_vhdl_expr fmt w

			 ))

		   ) va.branches  in

  match stmt with

  | SigAssign va -> pp_sig_cond fmt va       

  | Process p -> pp_process fmt p

  | SelectedSig va -> pp_sig_sel fmt va

(************************************************************************************)		   

(*                     Entities                                                     *)

(************************************************************************************)		   

(* TODO? Seems to appear optionally in entities *)

type vhdl_generic_t = unit

let pp_vhdl_generic fmt g = ()

type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort

let pp_vhdl_port_kind fmt p =

  match p with

  | InPort -> Format.fprintf fmt "in"

  | OutPort -> Format.fprintf fmt "in"

  | InoutPort -> Format.fprintf fmt "inout"

  | BufferPort -> Format.fprintf fmt "buffer"

type vhdl_port_t =

  {

    name: string;

    kind: vhdl_port_kind_t;

    typ: vhdl_type_t;

  }

let pp_vhdl_port fmt p =

  Format.fprintf fmt "%s : %a %a"

		 p.name

		 pp_vhdl_port_kind p.kind

		 pp_vhdl_type p.typ

type vhdl_entity_t =

  {

    name: string;

    generics: vhdl_generic_t list;

    ports: vhdl_port_t list;

  }

let pp_vhdl_entity fmt e =

  Format.fprintf

    fmt

    "@[<v 3>entity %s is@ %t%t@]@ end %s;@ "

    e.name

    (fun fmt -> List.iter (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g) e.generics)

    (fun fmt ->

     if e.ports = [] then () else

       Format.fprintf fmt "port (@[<hov 0>%a@]);" (Utils.fprintf_list ~sep:",@ " pp_vhdl_port) e.ports)

    e.name

(************************************************************************************)		   

(*                    Packages / Library loading                                    *)

(************************************************************************************)		   

(* Optional. Describes shared definitions *)

type vhdl_package_t =

  {

    name: string;

    shared_defs: vhdl_definition_t list;

  }

let pp_vhdl_package fmt p =

  Format.fprintf

    fmt

    "@[<v 3>package %s is@ %a@]@ end %s;@ "

    p.name

    (Utils.fprintf_list  ~sep:"@ " pp_vhdl_definition) p.shared_defs

    p.name

type vhdl_load_t = Library of string | Use of string list

let pp_vhdl_load fmt l =

  match l with

  | Library s -> Format.fprintf fmt "library %s;@ " s

  | Use sl -> Format.fprintf fmt "use %a;@ " (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl

(************************************************************************************)		   

(*                        Architecture / VHDL Design                                *)

(************************************************************************************)		   

    body: vhdl_concurrent_stmt_t list;

    "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s"

    (Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt) a.body

				body = [

				  ];