CristalCaveGem » LustreC

(* source: Synario VHDL Reference Manual - March 1997 *)

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

(* Types *)

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

let base_types =

  [

    "integer";

    "character";

    "bit";

    "real";

    "natural";

    "positive";

    "std_logic";

    "std_logic_vector";

  ]

type vhdl_type_t =

  | Base of string

  | Range of string option * int * int

  | Bit_vector of int * int

  | Array of int * int * vhdl_type_t

  | Enumerated of string list

let rec pp_vhdl_type fmt t =

  match t with

  | Base s ->

    Format.fprintf fmt "%s" s

  | Bit_vector (n, m) ->

    Format.fprintf fmt "bit_vector(%i downto %i)" n m

  | 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

  | Enumerated sl ->

    Format.fprintf fmt "(%a)"

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

      sl

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

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

  | CstBV of string * string

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

  | CstBV (pref, suff) ->

    Format.fprintf fmt "%s\"%s\"" pref suff

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

(* Declarations *)

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

(* TODO ? Shall we merge definition / declaration ? Do they appear at the same

   place or at different ones ? *)

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

type vhdl_declaration_t =

  | VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }

  | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t }

  | SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }

let pp_vhdl_declaration fmt decl =

  match decl with

  | VarDecl v ->

    Format.fprintf fmt "variable %s : %a%t;" v.name pp_vhdl_type v.typ

      (fun fmt ->

        match v.init_val with

        | Some initv ->

          Format.fprintf fmt " := %a" pp_cst_val initv

        | _ ->

          ())

  | CstDecl v ->

    Format.fprintf fmt "constant %s : %a := %a;" v.name pp_vhdl_type v.typ

      pp_cst_val v.init_val

  | SigDecl v ->

    Format.fprintf fmt "signal %s : %a%t;" v.name pp_vhdl_type v.typ (fun fmt ->

        match v.init_val with

        | Some initv ->

          Format.fprintf fmt " := %a" pp_cst_val initv

        | _ ->

          ())

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

(* Attributes for types, arrays, signals and strings *)

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

type 'basetype vhdl_type_attributes_t =

  | TAttNoArg of { id : string }

  | TAttIntArg of { id : string; arg : int }

  | TAttValArg of { id : string; arg : 'basetype }

  | TAttStringArg of { id : string; arg : string }

let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ]

let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ]

let typ_att_valarg = [ "image" ]

let typ_att_stringarg = [ "value" ]

let pp_type_attribute pp_val fmt tatt =

  match tatt with

  | TAttNoArg a ->

    Format.fprintf fmt "'%s" a.id

  | TAttIntArg a ->

    Format.fprintf fmt "'%s(%i)" a.id a.arg

  | TAttValArg a ->

    Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg

  | TAttStringArg a ->

    Format.fprintf fmt "'%s(%s)" a.id a.arg

type vhdl_array_attributes_t =

  | AAttInt of { id : string; arg : int }

  | AAttAscending

let pp_array_attribute fmt aatt =

  match aatt with

  | AAttInt a ->

    Format.fprintf fmt "'%s(%i)" a.id a.arg

  | AAttAscending ->

    Format.fprintf fmt "'ascending"

let array_att_intarg =

  [ "left"; "right"; "high"; "low"; "range"; "reverse_range"; "length" ]

type vhdl_signal_attributes_t = SigAtt of string

let pp_signal_attribute fmt sa =

  match sa with SigAtt s -> Format.fprintf fmt "'%s" s

let signal_att = [ "event"; "stable"; "last_value" ]

type vhdl_string_attributes_t = StringAtt of string

let pp_string_attribute fmt sa =

  match sa with StringAtt s -> Format.fprintf fmt "'%s" s

let signal_att = [ "simple_name"; "path_name"; "instance_name" ]

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

(* Expressions / Statements *)

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

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

type suffix_selection_t = Idx of int | Range of int * int

let pp_suffix_selection fmt sel =

  match sel with

  | Idx n ->

    Format.fprintf fmt "(%i)" n

  | Range (n, m) ->

    Format.fprintf fmt "(%i downto %i)" n m

type vhdl_expr_t =

  | Cst of cst_val_t

  | Var of string

  (* a signal or a variable *)

  | Sig of { name : string; att : vhdl_signal_attributes_t option }

  | SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }

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

let rec pp_vhdl_expr fmt e =

  match e with

  | Cst c ->

    pp_cst_val fmt c

  | Var s ->

    Format.fprintf fmt "%s" s

  | Sig s ->

    Format.fprintf fmt "%s%t" s.name (fun fmt ->

        match s.att with None -> () | Some att -> pp_signal_attribute fmt att)

  | SuffixMod s ->

    Format.fprintf fmt "%a %a" pp_vhdl_expr s.expr pp_suffix_selection

      s.selection

  | Op op -> (

    match op.args with

    | [] ->

      assert false

    | [ e1; e2 ] ->

      Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id

        pp_vhdl_expr e2

    | _ ->

      assert false

      (* all ops are binary up to now *)

      (* | _ -> Format.fprintf fmt "@[<hov 3>%s (%a)@]" op.id

         (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args *))

(* Available operators in the standard library. There are some restrictions on

   types. See reference doc. *)

let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**" ]

let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ]

let rel_funs = [ "<"; ">"; "<="; ">="; "/="; "=" ]

type vhdl_if_case_t = {

  if_cond : vhdl_expr_t;

  if_block : vhdl_sequential_stmt_t list;

}

and vhdl_sequential_stmt_t =

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

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

  | If of {

      if_cases : vhdl_if_case_t list;

      default : vhdl_sequential_stmt_t list option;

    }

  | Case of { guard : vhdl_expr_t; branches : vhdl_case_item_t list }

and vhdl_case_item_t = {

  when_cond : vhdl_expr_t;

  when_stmt : vhdl_sequential_stmt_t;

}

let rec pp_vhdl_sequential_stmt fmt stmt =

  match stmt with

  | VarAssign va ->

    Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs

  | SigSeqAssign va ->

    Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs

  | If ifva ->

    List.iteri

      (fun idx ifcase ->

        if idx = 0 then Format.fprintf fmt "@[<v 3>if"

        else Format.fprintf fmt "@ @[<v 3>elsif";

        Format.fprintf fmt " %a then@ %a@]" pp_vhdl_expr ifcase.if_cond

          pp_vhdl_sequential_stmts ifcase.if_block)

      ifva.if_cases;

    let _ =

      match ifva.default with

      | None ->

        ()

      | Some bl ->

        Format.fprintf fmt "@ @[<v 3>else@ %a@]" pp_vhdl_sequential_stmts bl

    in

    Format.fprintf fmt "@ end if;"

  | Case caseva ->

    Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;" pp_vhdl_expr

      caseva.guard

      (Utils.fprintf_list ~sep:"@ " pp_vhdl_case)

      caseva.branches

and pp_vhdl_sequential_stmts fmt l =

  Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l

and pp_vhdl_case fmt case =

  Format.fprintf fmt "when %a => %a" pp_vhdl_expr case.when_cond

    pp_vhdl_sequential_stmt case.when_stmt

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;

}

type vhdl_concurrent_stmt_t =

  | SigAssign of conditional_signal_t

  | Process of process_t

  | SelectedSig of selected_signal_t

(* type vhdl_statement_t =

   (* | DeclarationStmt of declaration_stmt_t *) | ConcurrentStmt of

   vhdl_concurrent_stmt_t | SequentialStmt of vhdl_sequential_stmt_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 *)

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

type vhdl_architecture_t = {

  name : string;

  entity : string;

  declarations : vhdl_declaration_t list;

  body : vhdl_concurrent_stmt_t list;

}

let pp_vhdl_architecture fmt a =

  Format.fprintf fmt

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

    a.entity

    (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration)

    a.declarations

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

    a.body a.name

(* TODO. Configuraiton is optional *)

type vhdl_configuration_t = unit

let pp_vhdl_configuration fmt c = ()

type vhdl_design_t = {

  packages : vhdl_package_t list;

  libraries : vhdl_load_t list;

  entities : vhdl_entity_t list;

  architectures : vhdl_architecture_t list;

  configuration : vhdl_configuration_t option;

}

let pp_vhdl_design fmt d =

  Format.fprintf fmt "@[<v 0>%a%t%a%t%a%t%a%t@]"

    (Utils.fprintf_list ~sep:"@ " pp_vhdl_package)

    d.packages

    (fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")

    (Utils.fprintf_list ~sep:"@ " pp_vhdl_load)

    d.libraries

    (fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ")

    (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity)

    d.entities

    (fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ")

    (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture)

    d.architectures

    (fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ")