diff --git a/clangml-transforms/for_memcad.ml b/clangml-transforms/for_memcad.ml
index 53303bacad3eea63b71b47b5cde33cc33ac86fed..366570706687b93663eae0c85767a54b29f3c649 100644
--- a/clangml-transforms/for_memcad.ml
+++ b/clangml-transforms/for_memcad.ml
@@ -1,7 +1,8 @@
module Log = Dolog.Log
let bin_op qual_type lhs kind rhs =
- Clang.Ast.node ~qual_type (Clang.Ast.BinaryOperator { lhs; kind; rhs })
+ Clang.Ast.node ~qual_type ~location:(Clang.Ast.location_of_node lhs)
+ (Clang.Ast.BinaryOperator { lhs; kind; rhs })
let int = Clang.Type.make (BuiltinType Int)
@@ -16,12 +17,13 @@ let fresh_var_name () =
fresh_var_counter := index + 1;
Printf.sprintf "__tmp_%d" index
-let declare_tmp qual_type =
+let declare_tmp ?location qual_type =
let tmp = fresh_var_name () in
- let decl_tmp = Clang.Ast.node ~qual_type (Clang.Ast.Decl [
- Clang.Ast.node ~qual_type (Clang.Ast.Var (Clang.Ast.var tmp qual_type))]) in
+ let decl_tmp = Clang.Ast.node ~qual_type ?location (Clang.Ast.Decl [
+ Clang.Ast.node ~qual_type ?location
+ (Clang.Ast.Var (Clang.Ast.var tmp qual_type))]) in
let tmp_var =
- Clang.Ast.node ~qual_type
+ Clang.Ast.node ~qual_type ?location
(Clang.Ast.DeclRef (Clang.Ast.identifier_name tmp)) in
tmp_var, decl_tmp
@@ -30,9 +32,11 @@ let assign_to_tmp ?qual_type expr =
match qual_type with
| None -> Clang.Type.of_node expr
| Some qual_type -> qual_type in
- let tmp_var, decl_tmp = declare_tmp qual_type in
- let assign_tmp = Clang.Ast.node ~qual_type (Clang.Ast.Expr (
- bin_op qual_type tmp_var Assign expr)) in
+ let location = Clang.Ast.location_of_node expr in
+ let tmp_var, decl_tmp = declare_tmp ~location qual_type in
+ let assign_tmp =
+ Clang.Ast.node ~qual_type ~location
+ (Clang.Ast.Expr (bin_op qual_type tmp_var Assign expr)) in
tmp_var, [decl_tmp; assign_tmp]
let rec cut_break (stmts : Clang.Ast.stmt list) =
@@ -73,8 +77,7 @@ let stmts_of_node (stmt, stmts) =
stmts_of_stmt stmt |> close_stmts stmts
let close_node ((stmt, _stmts) as node) =
- let location = Clang.Ast.location_of_node stmt in
- stmt_of_stmts ~location (stmts_of_node node)
+ stmt_of_stmts ~location:(Clang.Ast.location_of_node stmt) (stmts_of_node node)
let rec name_anonymous_fields (decl : Clang.Ast.decl list) =
match decl with
@@ -100,22 +103,25 @@ let rec name_anonymous_fields (decl : Clang.Ast.decl list) =
them. *)
let delayed_in_compound = ref false
-let make_conditional_operator qual_type delayed_stmts cond
+let make_conditional_operator qual_type delayed_stmts (cond : Clang.Ast.expr)
(then_branch, then_stmts) (else_branch, else_stmts) =
- let tmp_var, decl_tmp = declare_tmp qual_type in
- let assign branch =
- Clang.Ast.node (Clang.Ast.Expr (
- bin_op qual_type tmp_var Assign branch)) in
+ let location = Clang.Ast.location_of_node cond in
+ let tmp_var, decl_tmp = declare_tmp ~location qual_type in
+ let make_branch stmts expr =
+ let location = Clang.Ast.location_of_node expr in
+ let node =
+ Clang.Ast.node ~location
+ (Clang.Ast.Expr (bin_op qual_type tmp_var Assign expr)) in
+ close_stmt ~location stmts [node] in
let delayed_stmts =
Free_monoid.plus delayed_stmts
(Free_monoid.of_list [decl_tmp;
- Clang.Ast.node (Clang.Ast.If {
+ Clang.Ast.node ~location (Clang.Ast.If {
init = None;
condition_variable = None;
cond;
- then_branch = close_stmt then_stmts [assign then_branch];
- else_branch =
- Some (close_stmt else_stmts [assign else_branch])})]) in
+ then_branch = make_branch then_stmts then_branch;
+ else_branch = Some (make_branch else_stmts else_branch)})]) in
tmp_var, delayed_stmts
let make_condition delayed_stmts cond =
@@ -210,10 +216,11 @@ with type 'a Applicative.t = 'a Applicative.t = struct
let init, init_stmts =
Visit.visit [%refl: Clang.Ast.expr] []
init { env with assign_rhs = true } in
+ let location = Clang.Ast.location_of_node stmt in
let init : Clang.Ast.stmt = { stmt with desc =
Expr { stmt with desc = BinaryOperator {
lhs =
- Clang.Ast.node ~qual_type:var_type
+ Clang.Ast.node ~location ~qual_type:var_type
(Clang.Ast.DeclRef (Clang.Ast.identifier_name var_name));
kind = Assign; rhs = init }}} in
close_stmts init_stmts [decl; init]
@@ -225,10 +232,11 @@ with type 'a Applicative.t = 'a Applicative.t = struct
cond { env with in_condition = true } in
let body =
close_node (Visit.visit [%refl: Clang.Ast.stmt] [] body env) in
+ let location = Clang.Ast.location_of_node stmt in
body :: close_stmts cond_stmts [{ stmt with desc =
Clang.Ast.While { condition_variable = None; cond; body =
- Clang.Ast.node (Clang.Ast.Compound (body ::
- close_stmts cond_stmts []))}}]
+ Clang.Ast.node ~location
+ (Clang.Ast.Compound (body :: close_stmts cond_stmts []))}}]
| { desc = For { init; cond; inc; body; _ }; _} ->
let init, init_stmts =
Visit.visit [%refl: Clang.Ast.stmt option] [] init env in
@@ -258,8 +266,8 @@ with type 'a Applicative.t = 'a Applicative.t = struct
init @ close_stmts cond_stmts
[{ stmt with desc = While {
condition_variable = None; cond;
- body = stmt_of_stmts ~location (stmts_of_stmt body @ inc @
- close_stmts cond_stmts [])}}]
+ body = stmt_of_stmts ~location
+ (stmts_of_stmt body @ inc @ close_stmts cond_stmts [])}}]
(* assignCond special case!?! *)
| { desc = Return (Some cond); _ } when condition cond ->
let cond, delayed_stmts =
@@ -346,22 +354,24 @@ with type 'a Applicative.t = 'a Applicative.t = struct
| _ -> operand, delayed_stmts in
UnaryOperator { kind; operand }, delayed_stmts
- let rec visit_if(cond : Clang.Ast.expr) (then_branch : Clang.Ast.stmt)
+ let rec visit_if (cond : Clang.Ast.expr) (then_branch : Clang.Ast.stmt)
(else_branch : Clang.Ast.stmt option) env
: Clang.Ast.stmt_desc * accu =
match cond.desc with
| BinaryOperator { lhs; kind = LAnd; rhs } ->
- let then_branch =
- let (desc, accu) =
- visit_if rhs then_branch else_branch env in
- close_node (Clang.Ast.node desc, accu) in
- visit_if lhs then_branch else_branch env
+ let location = Clang.Ast.location_of_node cond in
+ let then_branch =
+ let (desc, accu) =
+ visit_if rhs then_branch else_branch env in
+ close_node (Clang.Ast.node ~location desc, accu) in
+ visit_if lhs then_branch else_branch env
| BinaryOperator { lhs; kind = LOr; rhs } ->
- let else_branch =
- let (desc, accu) =
- visit_if rhs then_branch else_branch env in
- close_node (Clang.Ast.node desc, accu) in
- visit_if lhs then_branch (Some else_branch) env
+ let location = Clang.Ast.location_of_node cond in
+ let else_branch =
+ let (desc, accu) =
+ visit_if rhs then_branch else_branch env in
+ close_node (Clang.Ast.node ~location desc, accu) in
+ visit_if lhs then_branch (Some else_branch) env
| _ ->
let cond, cond_stmts =
Visit.visit [%refl: Clang.Ast.expr] []
@@ -439,9 +449,10 @@ with type 'a Applicative.t = 'a Applicative.t = struct
expr, delayed_stmts
else
let qual_type = Clang.Type.of_node lhs in
+ let location = Clang.Ast.location_of_node expr in
let delayed_stmts =
Free_monoid.plus delayed_stmts (Free_monoid.of_item (
- Clang.Ast.node ~qual_type (Clang.Ast.Expr expr))) in
+ Clang.Ast.node ~location ~qual_type (Clang.Ast.Expr expr))) in
lhs, delayed_stmts in
let make_op_assign lhs kind rhs =
{ expr with desc = Clang.Ast.BinaryOperator {
@@ -530,8 +541,10 @@ with type 'a Applicative.t = 'a Applicative.t = struct
| _ -> assert false in
let qual_type = Clang.Type.of_node operand in
let tmp_var, stmts = assign_to_tmp operand in
- let increment_operand = Clang.Ast.node ~qual_type (Clang.Ast.Expr (
- make_op_assign operand kind (integer_literal 1))) in
+ let location = Clang.Ast.location_of_node expr in
+ let increment_operand =
+ Clang.Ast.node ~location ~qual_type
+ (Clang.Ast.Expr (make_op_assign operand kind (integer_literal 1))) in
let delayed_stmts =
plus_with_warning delayed_stmts
(Free_monoid.of_list (stmts @ [increment_operand])) in
@@ -589,17 +602,19 @@ with type 'a Applicative.t = 'a Applicative.t = struct
| [] -> failwith "no case in switch"
| hd :: tl ->
List.fold_left (fun a b -> bin_op int a LAnd b) hd tl in
- let cond =
- bin_op int from_previous_var LOr cond in
+ let cond = bin_op int from_previous_var LOr cond in
+ let location = Clang.Ast.location_of_node cond in
let assign var value =
- Clang.Ast.node (Clang.Ast.Expr (
+ Clang.Ast.node ~location (Clang.Ast.Expr (
bin_op int var Assign (integer_literal value))) in
let stmts =
match cut_break stmts with
| None -> assign from_previous_var 1 :: stmts
| Some stmts -> assign from_previous_var 0 :: stmts in
- Clang.Ast.node (Clang.Ast.If { init = None; condition_variable = None;
- cond; then_branch = Clang.Ast.node (Clang.Ast.Compound stmts);
+ Clang.Ast.node ~location
+ (Clang.Ast.If { init = None; condition_variable = None;
+ cond;
+ then_branch = Clang.Ast.node ~location (Clang.Ast.Compound stmts);
else_branch = None }) in
Compound (close_stmts cond_delayed_stmts (
cond_stmts @ from_previous_stmts @ cases)),
diff --git a/clangml-transforms/for_memcad.mli b/clangml-transforms/for_memcad.mli
index ffde4b4b9e20ac1fc93c0eaa95da401d72b06df0..b4d4fe6aa0d841943d269e91a44d128bddef9d09 100644
--- a/clangml-transforms/for_memcad.mli
+++ b/clangml-transforms/for_memcad.mli
@@ -8,7 +8,7 @@ val integer_literal : ?location:Clang.Ast.source_location -> int -> Clang.Ast.ex
val stmts_of_stmt : Clang.Ast.stmt -> Clang.Ast.stmt list
-val stmt_of_stmts : ?location:Clang.Ast.source_location ->
+val stmt_of_stmts : ?decoration:Clang.Ast.decoration ->
Clang.Ast.stmt list -> Clang.Ast.stmt
val transform_decl : Clang.Decl.t -> Clang.Decl.t