Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor TwoPointLattice (S: TWO_POINT_LATTICE_STRUCTS): TWO_POINT_LATTICE = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | structure Set = DisjointSet | |
15 | structure List = AppendList | |
16 | ||
17 | datatype t = T of value Set.t | |
18 | and value = | |
19 | Bottom of (unit -> unit) List.t ref (* If I become Top, then run these. *) | |
20 | | Top | |
21 | ||
22 | fun value (T s) = Set.! s | |
23 | ||
24 | fun toString e = | |
25 | case value e of | |
26 | Bottom _ => bottom | |
27 | | Top => top | |
28 | ||
29 | val layout = Layout.str o toString | |
30 | ||
31 | fun new (): t = T (Set.singleton (Bottom (ref List.empty))) | |
32 | ||
33 | fun equals (T s, T s') = Set.equals (s, s') | |
34 | ||
35 | fun addHandler (e, h) = | |
36 | case value e of | |
37 | Bottom hs => hs := List.cons (h, !hs) | |
38 | | Top => h () | |
39 | ||
40 | fun isTop s = | |
41 | case value s of | |
42 | Top => true | |
43 | | _ => false | |
44 | ||
45 | fun isBottom s = | |
46 | case value s of | |
47 | Bottom _ => true | |
48 | | _ => false | |
49 | ||
50 | fun runHandlers hs = List.foreach (!hs, fn h => h ()) | |
51 | ||
52 | fun makeTop (T s) = | |
53 | case Set.! s of | |
54 | Top => () | |
55 | | Bottom hs => (Set.:= (s, Top); runHandlers hs) | |
56 | ||
57 | fun from <= to = | |
58 | if equals (from, to) | |
59 | then () | |
60 | else | |
61 | case (value from, value to) of | |
62 | (_, Top) => () | |
63 | | (Top, _) => makeTop to | |
64 | | (Bottom hs, _) => hs := List.cons (fn () => makeTop to, !hs) | |
65 | ||
66 | fun == (T s, T s') = | |
67 | if Set.equals (s, s') | |
68 | then () | |
69 | else | |
70 | let val e = Set.! s | |
71 | val e' = Set.! s' | |
72 | val _ = Set.union (s, s') | |
73 | in | |
74 | case (e, e') of | |
75 | (Top, Top) => () | |
76 | | (Bottom hs, Top) => (Set.:= (s, e'); runHandlers hs) | |
77 | | (Top, Bottom hs) => (Set.:= (s, e); runHandlers hs) | |
78 | | (Bottom hs, Bottom hs') => | |
79 | Set.:= (s, Bottom (ref (List.append (!hs, !hs')))) | |
80 | end | |
81 | ||
82 | end |