l4/pkg/ocaml/contrib/otherlibs/labltk/compiler/tsort.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16
  17 (* $Id: tsort.ml 4745 2002-04-26 12:16:26Z furuse $ *)
  18
  19 open StdLabels
  20
  21 (* Topological Sort.list *)
  22 (* d'apres More Programming Pearls *)
  23
  24 (* node * pred count * successors *)
  25
  26 type 'a entry =
  27     {node : 'a;
  28      mutable pred_count : int;
  29      mutable successors : 'a entry list
  30      }
  31
  32 type 'a porder = 'a entry list ref
  33
  34 exception Cyclic
  35
  36 let find_entry order node =
  37   let rec search_entry =
  38     function
  39       [] -> raise Not_found
  40     | x::l -> if x.node = node then x else search_entry l
  41   in
  42   try
  43     search_entry !order
  44   with
  45     Not_found -> let entry = {node = node;
  46                               pred_count = 0;
  47                               successors = []} in
  48                   order := entry::!order;
  49                   entry
  50
  51 let create () = ref []
  52
  53 (* Inverted args because Sort.list builds list in reverse order *)
  54 let add_relation order (succ,pred) =
  55   let pred_entry = find_entry order pred
  56   and succ_entry = find_entry order succ in
  57     succ_entry.pred_count <- succ_entry.pred_count + 1;
  58     pred_entry.successors <- succ_entry::pred_entry.successors
  59
  60 (* Just add it *)
  61 let add_element order e =
  62   ignore (find_entry order e)
  63
  64 let sort order =
  65     let q = Queue.create ()
  66     and result = ref [] in
  67     List.iter !order
  68       ~f:(function {pred_count = n} as node ->
  69                 if n = 0 then Queue.add node q);
  70     begin try
  71       while true do
  72         let t = Queue.take q in
  73           result := t.node :: !result;
  74           List.iter t.successors ~f:
  75             begin fun s ->
  76               let n = s.pred_count - 1 in
  77               s.pred_count <- n;
  78               if n = 0 then Queue.add s q
  79             end
  80         done
  81     with
  82       Queue.Empty ->
  83          List.iter !order
  84            ~f:(fun node -> if node.pred_count <> 0
  85                               then raise Cyclic)
  86     end;
  87     !result
  88
  89