Mercurial > urweb

comparison src/corify.sml @ 48:0a5c312de09a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of FFI
author Adam Chlipala <adamc@hcoop.net>
date Sun, 22 Jun 2008 09:27:29 -0400
parents 44a1bc863f0f
children 874e877d2c51
comparison
equal deleted inserted replaced
47:ac4c0b4111ba 48:0a5c312de09a
58 58
59 val empty : t 59 val empty : t
60 60
61 val enter : t -> t 61 val enter : t -> t
62 val leave : t -> {outer : t, inner : t} 62 val leave : t -> {outer : t, inner : t}
63 val ffi : string -> t
63 64
64 val bindCore : t -> string -> int -> t * int 65 val bindCore : t -> string -> int -> t * int
65 val lookupCoreById : t -> int -> int option 66 val lookupCoreById : t -> int -> int option
66 val lookupCoreByName : t -> string -> int 67
68 datatype core =
69 Normal of int
70 | Ffi of string
71 val lookupCoreByName : t -> string -> core
67 72
68 val bindStr : t -> string -> int -> t -> t 73 val bindStr : t -> string -> int -> t -> t
69 val lookupStrById : t -> int -> t 74 val lookupStrById : t -> int -> t
70 val lookupStrByName : string * t -> t 75 val lookupStrByName : string * t -> t
71 76
72 val bindFunctor : t -> string -> int -> int -> L.str -> t 77 val bindFunctor : t -> string -> int -> int -> L.str -> t
73 val lookupFunctorById : t -> int -> int * L.str 78 val lookupFunctorById : t -> int -> int * L.str
74 val lookupFunctorByName : string * t -> int * L.str 79 val lookupFunctorByName : string * t -> int * L.str
75 end = struct 80 end = struct
76 81
77 datatype flattening = F of { 82 datatype flattening =
78 core : int SM.map, 83 FNormal of {core : int SM.map,
79 strs : flattening SM.map, 84 strs : flattening SM.map,
80 funs : (int * L.str) SM.map 85 funs : (int * L.str) SM.map}
81 } 86 | FFfi of string
82 87
83 type t = { 88 type t = {
84 core : int IM.map, 89 core : int IM.map,
85 strs : flattening IM.map, 90 strs : flattening IM.map,
86 funs : (int * L.str) IM.map, 91 funs : (int * L.str) IM.map,
90 95
91 val empty = { 96 val empty = {
92 core = IM.empty, 97 core = IM.empty,
93 strs = IM.empty, 98 strs = IM.empty,
94 funs = IM.empty, 99 funs = IM.empty,
95 current = F { core = SM.empty, strs = SM.empty, funs = SM.empty }, 100 current = FNormal { core = SM.empty, strs = SM.empty, funs = SM.empty },
96 nested = [] 101 nested = []
97 } 102 }
103
104 datatype core =
105 Normal of int
106 | Ffi of string
98 107
99 fun bindCore {core, strs, funs, current, nested} s n = 108 fun bindCore {core, strs, funs, current, nested} s n =
100 let 109 let
101 val n' = alloc () 110 val n' = alloc ()
102 111
103 val current = 112 val current =
104 let 113 case current of
105 val F {core, strs, funs} = current 114 FFfi _ => raise Fail "Binding inside FFfi"
106 in 115 | FNormal {core, strs, funs} =>
107 F {core = SM.insert (core, s, n'), 116 FNormal {core = SM.insert (core, s, n'),
108 strs = strs, 117 strs = strs,
109 funs = funs} 118 funs = funs}
110 end
111 in 119 in
112 ({core = IM.insert (core, n, n'), 120 ({core = IM.insert (core, n, n'),
113 strs = strs, 121 strs = strs,
114 funs = funs, 122 funs = funs,
115 current = current, 123 current = current,
117 n') 125 n')
118 end 126 end
119 127
120 fun lookupCoreById ({core, ...} : t) n = IM.find (core, n) 128 fun lookupCoreById ({core, ...} : t) n = IM.find (core, n)
121 129
122 fun lookupCoreByName ({current = F {core, ...}, ...} : t) x = 130 fun lookupCoreByName ({current, ...} : t) x =
123 case SM.find (core, x) of 131 case current of
124 NONE => raise Fail "Corify.St.lookupCoreByName" 132 FFfi m => Ffi m
125 | SOME n => n 133 | FNormal {core, ...} =>
134 case SM.find (core, x) of
135 NONE => raise Fail "Corify.St.lookupCoreByName"
136 | SOME n => Normal n
126 137
127 fun enter {core, strs, funs, current, nested} = 138 fun enter {core, strs, funs, current, nested} =
128 {core = core, 139 {core = core,
129 strs = strs, 140 strs = strs,
130 funs = funs, 141 funs = funs,
131 current = F {core = SM.empty, 142 current = FNormal {core = SM.empty,
132 strs = SM.empty, 143 strs = SM.empty,
133 funs = SM.empty}, 144 funs = SM.empty},
134 nested = current :: nested} 145 nested = current :: nested}
135 146
136 fun dummy f = {core = IM.empty, 147 fun dummy f = {core = IM.empty,
137 strs = IM.empty, 148 strs = IM.empty,
138 funs = IM.empty, 149 funs = IM.empty,
146 current = m1, 157 current = m1,
147 nested = rest}, 158 nested = rest},
148 inner = dummy current} 159 inner = dummy current}
149 | leave _ = raise Fail "Corify.St.leave" 160 | leave _ = raise Fail "Corify.St.leave"
150 161
151 fun bindStr ({core, strs, funs, current = F {core = mcore, strs = mstrs, funs = mfuns}, nested} : t) 162 fun ffi m = dummy (FFfi m)
163
164 fun bindStr ({core, strs, funs, current = FNormal {core = mcore, strs = mstrs, funs = mfuns}, nested} : t)
152 x n ({current = f, ...} : t) = 165 x n ({current = f, ...} : t) =
153 {core = core, 166 {core = core,
154 strs = IM.insert (strs, n, f), 167 strs = IM.insert (strs, n, f),
155 funs = funs, 168 funs = funs,
156 current = F {core = mcore, 169 current = FNormal {core = mcore,
157 strs = SM.insert (mstrs, x, f), 170 strs = SM.insert (mstrs, x, f),
158 funs = mfuns}, 171 funs = mfuns},
159 nested = nested} 172 nested = nested}
173 | bindStr _ _ _ _ = raise Fail "Corify.St.bindStr"
160 174
161 fun lookupStrById ({strs, ...} : t) n = 175 fun lookupStrById ({strs, ...} : t) n =
162 case IM.find (strs, n) of 176 case IM.find (strs, n) of
163 NONE => raise Fail "Corify.St.lookupStrById" 177 NONE => raise Fail "Corify.St.lookupStrById"
164 | SOME f => dummy f 178 | SOME f => dummy f
165 179
166 fun lookupStrByName (m, {current = F {strs, ...}, ...} : t) = 180 fun lookupStrByName (m, {current = FNormal {strs, ...}, ...} : t) =
167 case SM.find (strs, m) of 181 (case SM.find (strs, m) of
168 NONE => raise Fail "Corify.St.lookupStrByName" 182 NONE => raise Fail "Corify.St.lookupStrByName"
169 | SOME f => dummy f 183 | SOME f => dummy f)
170 184 | lookupStrByName _ = raise Fail "Corify.St.lookupStrByName"
171 fun bindFunctor ({core, strs, funs, current = F {core = mcore, strs = mstrs, funs = mfuns}, nested} : t) 185
186 fun bindFunctor ({core, strs, funs, current = FNormal {core = mcore, strs = mstrs, funs = mfuns}, nested} : t)
172 x n na str = 187 x n na str =
173 {core = core, 188 {core = core,
174 strs = strs, 189 strs = strs,
175 funs = IM.insert (funs, n, (na, str)), 190 funs = IM.insert (funs, n, (na, str)),
176 current = F {core = mcore, 191 current = FNormal {core = mcore,
177 strs = mstrs, 192 strs = mstrs,
178 funs = SM.insert (mfuns, x, (na, str))}, 193 funs = SM.insert (mfuns, x, (na, str))},
179 nested = nested} 194 nested = nested}
195 | bindFunctor _ _ _ _ _ = raise Fail "Corify.St.bindFunctor"
180 196
181 fun lookupFunctorById ({funs, ...} : t) n = 197 fun lookupFunctorById ({funs, ...} : t) n =
182 case IM.find (funs, n) of 198 case IM.find (funs, n) of
183 NONE => raise Fail "Corify.St.lookupFunctorById" 199 NONE => raise Fail "Corify.St.lookupFunctorById"
184 | SOME v => v 200 | SOME v => v
185 201
186 fun lookupFunctorByName (m, {current = F {funs, ...}, ...} : t) = 202 fun lookupFunctorByName (m, {current = FNormal {funs, ...}, ...} : t) =
187 case SM.find (funs, m) of 203 (case SM.find (funs, m) of
188 NONE => raise Fail "Corify.St.lookupFunctorByName" 204 NONE => raise Fail "Corify.St.lookupFunctorByName"
189 | SOME v => v 205 | SOME v => v)
206 | lookupFunctorByName _ = raise Fail "Corify.St.lookupFunctorByName"
190 207
191 end 208 end
192 209
193 210
194 fun corifyKind (k, loc) = 211 fun corifyKind (k, loc) =
211 | SOME n => (L'.CNamed n, loc)) 228 | SOME n => (L'.CNamed n, loc))
212 | L.CModProj (m, ms, x) => 229 | L.CModProj (m, ms, x) =>
213 let 230 let
214 val st = St.lookupStrById st m 231 val st = St.lookupStrById st m
215 val st = foldl St.lookupStrByName st ms 232 val st = foldl St.lookupStrByName st ms
216 val n = St.lookupCoreByName st x 233 in
217 in 234 case St.lookupCoreByName st x of
218 (L'.CNamed n, loc) 235 St.Normal n => (L'.CNamed n, loc)
236 | St.Ffi m => (L'.CFfi (m, x), loc)
219 end 237 end
220 238
221 | L.CApp (c1, c2) => (L'.CApp (corifyCon st c1, corifyCon st c2), loc) 239 | L.CApp (c1, c2) => (L'.CApp (corifyCon st c1, corifyCon st c2), loc)
222 | L.CAbs (x, k, c) => (L'.CAbs (x, corifyKind k, corifyCon st c), loc) 240 | L.CAbs (x, k, c) => (L'.CAbs (x, corifyKind k, corifyCon st c), loc)
223 241
237 | SOME n => (L'.ENamed n, loc)) 255 | SOME n => (L'.ENamed n, loc))
238 | L.EModProj (m, ms, x) => 256 | L.EModProj (m, ms, x) =>
239 let 257 let
240 val st = St.lookupStrById st m 258 val st = St.lookupStrById st m
241 val st = foldl St.lookupStrByName st ms 259 val st = foldl St.lookupStrByName st ms
242 val n = St.lookupCoreByName st x 260 in
243 in 261 case St.lookupCoreByName st x of
244 (L'.ENamed n, loc) 262 St.Normal n => (L'.ENamed n, loc)
263 | St.Ffi m => (L'.EFfi (m, x), loc)
245 end 264 end
246 | L.EApp (e1, e2) => (L'.EApp (corifyExp st e1, corifyExp st e2), loc) 265 | L.EApp (e1, e2) => (L'.EApp (corifyExp st e1, corifyExp st e2), loc)
247 | L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, corifyCon st dom, corifyCon st ran, corifyExp st e1), loc) 266 | L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, corifyCon st dom, corifyCon st ran, corifyExp st e1), loc)
248 | L.ECApp (e1, c) => (L'.ECApp (corifyExp st e1, corifyCon st c), loc) 267 | L.ECApp (e1, c) => (L'.ECApp (corifyExp st e1, corifyCon st c), loc)
249 | L.ECAbs (x, k, e1) => (L'.ECAbs (x, corifyKind k, corifyExp st e1), loc) 268 | L.ECAbs (x, k, e1) => (L'.ECAbs (x, corifyKind k, corifyExp st e1), loc)
277 val (ds, {inner, outer}) = corifyStr (str, st) 296 val (ds, {inner, outer}) = corifyStr (str, st)
278 val st = St.bindStr outer x n inner 297 val st = St.bindStr outer x n inner
279 in 298 in
280 (ds, st) 299 (ds, st)
281 end 300 end
301
302 | L.DFfiStr (x, n, _) =>
303 let
304 val st = St.bindStr st x n (St.ffi x)
305 in
306 ([], st)
307 end
308
282 309
283 and corifyStr ((str, _), st) = 310 and corifyStr ((str, _), st) =
284 case str of 311 case str of
285 L.StrConst ds => 312 L.StrConst ds =>
286 let 313 let
322 fun maxName ds = foldl (fn ((d, _), n) => 349 fun maxName ds = foldl (fn ((d, _), n) =>
323 case d of 350 case d of
324 L.DCon (_, n', _, _) => Int.max (n, n') 351 L.DCon (_, n', _, _) => Int.max (n, n')
325 | L.DVal (_, n', _ , _) => Int.max (n, n') 352 | L.DVal (_, n', _ , _) => Int.max (n, n')
326 | L.DSgn (_, n', _) => Int.max (n, n') 353 | L.DSgn (_, n', _) => Int.max (n, n')
327 | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))) 354 | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))
355 | L.DFfiStr (_, n', _) => Int.max (n, n'))
328 0 ds 356 0 ds
329 357
330 and maxNameStr (str, _) = 358 and maxNameStr (str, _) =
331 case str of 359 case str of
332 L.StrConst ds => maxName ds 360 L.StrConst ds => maxName ds