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 NPointLattice (S: N_POINT_LATTICE_STRUCTS): N_POINT_LATTICE = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | val N = List.length names - 1 | |
15 | ||
16 | structure Set = DisjointSet | |
17 | ||
18 | type value = int * (unit -> unit) AppendList.t ref List.t | |
19 | datatype t = T of value Set.t | |
20 | ||
21 | fun value (T s) = Set.! s | |
22 | ||
23 | fun toString e = | |
24 | case value e of | |
25 | (n, _) => List.nth (names, n) | |
26 | ||
27 | val layout = Layout.str o toString | |
28 | ||
29 | fun new (): t = | |
30 | T (Set.singleton (0, List.duplicate (N, fn () => ref AppendList.empty))) | |
31 | ||
32 | fun equals (T s, T s') = Set.equals (s, s') | |
33 | ||
34 | fun whenN (s, n', h') = | |
35 | case value s of | |
36 | (n, hss) => if n' < 0 orelse n' > N | |
37 | then Error.bug "NPointLattice.whenN" | |
38 | else if n >= n' | |
39 | then h' () | |
40 | else let | |
41 | val hs = List.nth (hss, n' - n - 1) | |
42 | in | |
43 | hs := AppendList.cons (h', !hs) | |
44 | end | |
45 | ||
46 | fun isN (s, n') = | |
47 | case value s of | |
48 | (n, _) => if n' < 0 orelse n' > N | |
49 | then Error.bug "NPointLattice.isN" | |
50 | else n = n' | |
51 | ||
52 | fun up (T s) = | |
53 | case Set.! s of | |
54 | (n, hss) => if n = N | |
55 | then () | |
56 | else (Set.:= (s, (n + 1, tl hss)) ; | |
57 | AppendList.foreach (!(hd hss), fn h => h ())) | |
58 | ||
59 | fun makeN (s, n') = | |
60 | case value s of | |
61 | (n, _) => if n' < 0 orelse n' > N | |
62 | then Error.bug "NPointLattice.makeN" | |
63 | else if n >= n' | |
64 | then () | |
65 | else (up s ; makeN (s, n')) | |
66 | ||
67 | fun from <= to = | |
68 | if equals (from, to) | |
69 | then () | |
70 | else | |
71 | case (value from, value to) of | |
72 | ((n,hss), (n',_)) => | |
73 | (makeN (to, n) ; | |
74 | List.foreachi | |
75 | (hss, fn (i,hs) => | |
76 | if n + i + 1 > n' | |
77 | then hs := AppendList.cons (fn () => makeN (to, n + i + 1), !hs) | |
78 | else ())) | |
79 | ||
80 | fun == (T s, T s') = | |
81 | if Set.equals (s, s') | |
82 | then () | |
83 | else | |
84 | let | |
85 | val e = Set.! s | |
86 | val e' = Set.! s' | |
87 | val _ = Set.union (s, s') | |
88 | in | |
89 | case (e, e') of | |
90 | ((n,hss), (n',hss')) => | |
91 | let | |
92 | val n'' = Int.max (n, n') | |
93 | ||
94 | fun doit (n, hss) = | |
95 | let | |
96 | val rec drop | |
97 | = fn (hss, 0: Int.t) => hss | |
98 | | (hs::hss, n) => | |
99 | (AppendList.foreach | |
100 | (!hs, fn h => h ()) ; | |
101 | drop (hss, n - 1)) | |
102 | | ([], _) => Error.bug "NPointLattice.==" | |
103 | in | |
104 | drop (hss, n'' - n) | |
105 | end | |
106 | val hss = doit (n, hss) | |
107 | val hss' = doit (n', hss') | |
108 | val hss'' | |
109 | = List.map2 | |
110 | (hss, hss', fn (hs, hs') => | |
111 | ref (AppendList.append (!hs, !hs'))) | |
112 | in | |
113 | Set.:= (s, (n'', hss'')) | |
114 | end | |
115 | end | |
116 | ||
117 | end |