X-Git-Url: https://git.xandkar.net/?p=tiger.ml.git;a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_dag.ml;fp=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_dag.ml;h=f843506048c35c7e894f472694ee62611e047e93;hp=0000000000000000000000000000000000000000;hb=e6e82c0866db4eb08f956b2582e5c2ed5399e986;hpb=d1fe69d31f39d5481d739e592863e1126cfe0c35

diff --git a/compiler/src/lib/tiger/tiger_dag.ml b/compiler/src/lib/tiger/tiger_dag.ml
new file mode 100644
index 0000000..f843506
--- /dev/null
+++ b/compiler/src/lib/tiger/tiger_dag.ml
@@ -0,0 +1,39 @@
+module List = ListLabels
+
+module Map = Tiger_map
+module Opt = Tiger_opt
+
+type t =
+  unit
+
+type count =
+  { parents  : int
+  ; children : int
+  }
+
+let of_list pairs =
+  let incr counts k incr =
+    let prev = Opt.get (Map.get counts ~k) ~default:{parents=0; children=0} in
+    Map.set counts ~k ~v:(incr prev)
+  in
+  let incr_parents  count = {count with parents  = succ count.parents} in
+  let incr_children count = {count with children = succ count.children} in
+  let zero_children counts =
+    List.filter (Map.to_list counts) ~f:(fun (_, {children=c; _}) -> c = 0 )
+  in
+  let zero_parents counts =
+    List.filter (Map.to_list counts) ~f:(fun (_, {parents=p; _}) -> p = 0 )
+  in
+  let counts =
+    List.fold_left pairs ~init:Map.empty ~f:(
+      fun counts (p, c) ->
+        let counts = incr counts p incr_children in
+        let counts = incr counts c incr_parents  in
+        counts
+    )
+  in
+  (* At least one node with no in-coming links and
+   * at least one node with no out-going links. *)
+  match (zero_parents counts, zero_children counts) with
+  | _ :: _, _ :: _ -> Ok ()
+  |      _,      _ -> Error `Cycle