Summary: more surgery functions

API to let one forge a frozen state out of another frozen state
plus some frozen bits

1 files changed, 30 insertions, 14 deletions

diff --git a/library/summary.ml b/library/summary.ml
index 7a0064a1f..a44721606 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -123,21 +123,22 @@ let nop () = ()
 
 type frozen_bits = (int * Dyn.t) list
 
+let ids_of_string_list complement ids =
+  if not complement then List.map String.hash ids
+  else
+    let fold accu id =
+      let id = String.hash id in
+      Int.Set.remove id accu
+    in
+    let ids = List.fold_left fold !all_declared_summaries ids in
+    Int.Set.elements ids
+
 let freeze_summary ~marshallable ?(complement=false) ids =
-  let ids =
-    if not complement then List.map String.hash ids
-    else
-      let fold accu id =
-        let id = String.hash id in
-        Int.Set.remove id accu
-      in
-      let ids = List.fold_left fold !all_declared_summaries ids in
-      Int.Set.elements ids
-  in
-    List.map (fun id ->
-      let (_, summary) = Int.Map.find id !summaries in
-      id, summary.freeze_function marshallable)
-    ids
+  let ids = ids_of_string_list complement ids in
+  List.map (fun id ->
+    let (_, summary) = Int.Map.find id !summaries in
+    id, summary.freeze_function marshallable)
+  ids
 
 let unfreeze_summary datas =
   List.iter
@@ -150,6 +151,21 @@ let unfreeze_summary datas =
         iraise e)
   datas
 
+let surgery_summary { summaries; ml_module } bits =
+  let summaries = List.map (fun (id, _ as orig) ->
+      try id, List.assoc id bits
+      with Not_found -> orig)
+    summaries in
+  { summaries; ml_module }
+
+let project_summary { summaries; ml_module } ?(complement=false) ids =
+  let ids = ids_of_string_list complement ids in
+  List.filter (fun (id, _) -> List.mem id ids) summaries
+
+let pointer_equal l1 l2 =
+  CList.for_all2eq
+    (fun (id1,v1) (id2,v2) -> id1 = id2 && Dyn.pointer_equal v1 v2) l1 l2
+
 (** All-in-one reference declaration + registration *)
 
 let ref ?(freeze=fun _ r -> r) ~name x =