Keep more location informations

clangml-transforms/for_memcad.ml

 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)),