CristalCaveGem » LustreC

let rec pp_c_dimension fmt dim =

  match dim.Dimension.dim_desc with

  | Dident id       ->

    fprintf fmt "%s" id

  | Dint i          ->

    fprintf fmt "%d" i

  | Dbool b         ->

    fprintf fmt "%B" b

  | Dite (i, t, e)  ->

    fprintf fmt "((%a)?%a:%a)"

       pp_c_dimension i pp_c_dimension t pp_c_dimension e

 | Dappl (f, args) ->

     fprintf fmt "%a" (Basic_library.pp_c f pp_c_dimension) args

 | Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim'

 | Dvar       -> fprintf fmt "_%s" (Utils.name_of_dimension dim.dim_id)

 | Dunivar    -> fprintf fmt "'%s" (Utils.name_of_dimension dim.dim_id)

    | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false

let pp_loop_var pp_value fmt lv =

 | LAcc i -> fprintf fmt "[%a]" (pp_c_val "" pp_value) i

let pp_suffix pp_value fmt loop_vars =

 Utils.fprintf_list ~sep:"" (pp_loop_var pp_value) fmt loop_vars

(* Prints a value expression [v], with internal function calls only.

   [pp_var] is a printer for variables (typically [pp_c_var_read]),

   but an offset suffix may be added for array variables

*)

(* Prints a constant value before a suffix (needs casting) *)

let rec pp_c_const_suffix var_type fmt c =

  match c with

    | Const_int i     -> pp_print_int fmt i

    | Const_real r    -> pp_print_string fmt r

    | Const_float r   -> pp_print_float fmt r

    | Const_tag t     -> pp_c_tag fmt t

    | Const_array ca  -> let var_type = Types.array_element_type var_type in

                         fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca

    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl

    | Const_string _ -> assert false (* string occurs in annotations not in C *)

(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)

let rec pp_value_suffix self var_type loop_vars pp_value fmt value =

(*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)

 | (x, LAcc i) :: q, _ when is_const_index i ->

   let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in

   pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value

 | (_, LInt r) :: q, Cst (Const_array cl) ->

   let var_type = Types.array_element_type var_type in

   pp_value_suffix self var_type q pp_value fmt (Cst (List.nth cl !r))

   let var_type = Types.array_element_type var_type in

   pp_value_suffix self var_type q pp_value fmt (List.nth vl !r)

 | loop_var    :: q, Array vl      ->

   let var_type = Types.array_element_type var_type in

   Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type q pp_value)) vl (pp_suffix pp_value) [loop_var]

   pp_value_suffix self var_type q pp_value fmt v

   Basic_library.pp_c n (pp_value_suffix self var_type loop_vars pp_value) fmt vl

   let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in

   pp_value_suffix self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v

 | _               , LocalVar v    -> Format.fprintf fmt "%a%a" pp_value v (pp_suffix pp_value) loop_vars

 | _               , StateVar v    ->

    (* array memory vars are represented by an indirection to a local var with the right type,

       in order to avoid casting everywhere. *)

   if Types.is_array_type v.var_type

   then Format.fprintf fmt "%a%a" pp_value v (pp_suffix pp_value) loop_vars

   else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v (pp_suffix pp_value) loop_vars

 | _               , Cst cst       -> pp_c_const_suffix var_type fmt cst

 | _               , _             -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type Machine_code.pp_val value (pp_suffix pp_value) loop_vars; assert false)

	(pp_value_suffix self var_type loop_vars pp_var) var_name

	(pp_value_suffix self var_type loop_vars pp_var) value

    | _ -> (Format.eprintf "internal error: Basic_library.pp_c %s@." i; assert false)

    | _ -> (Format.eprintf "internal error: Basic_library.pp_java %s@." i; assert false)

  | _ -> (Format.eprintf "internal error: Basic_library.pp_horn %s@." i; assert false)

    | Expr_access (e1, d)

    | Expr_power (e1, d) -> add_dep lhs_is_mem lhs e1 (add_dep lhs_is_mem lhs (expr_of_dimension d) g)

type offset =

| Index of Dimension.dim_expr

| Field of label

  Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"

  (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)

  machine_code);

  if !Options.optimization >= 2 then

    begin

      Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"

	(Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)

	machine_code);

    end;

(* Some optimizations may yield denormalized values. Similar to normalize_expr *)

(*

let normalize_value v =

  let rec norm_cst offset cst =

    match cst, offset with

    | Const_int   _   , _

    | Const_real  _   , _ 

    | Const_float _   , _          -> cst

    | Const_array args, Index i::q -> if Dimension.is_dimension_const 

    | Const_tag of label

    | Const_string of string (* used only for annotations *)

    | Const_struct of (label * constant) list

  let rec norm_value offset v =

    match v with

    | Cst _ 

    | LocalVar _

    | StateVar _ -> v

    | Fun (id, args) -> Fun (id, List.map normalize_value args)

    | Array args -> Array List.map normalize_value args

    | Access of value_t * value_t

    | Power of value_t * value_t

  in norm [] v

*)

 %prec POWER                { fun typ -> typ }

let struct_field_type ty field =

  match (dynamic_type ty).tdesc with

  | Tstruct fields ->

    (try

       List.assoc field fields

     with Not_found -> assert false)

  | _              -> assert false