Mercurial > urweb

comparison src/jscomp.sml @ 572:57018f21cd5c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Handling singnal bind
author Adam Chlipala <adamc@hcoop.net>
date Sun, 21 Dec 2008 12:30:57 -0500
parents 162d5308e34f
children ac947e2f29ff
comparison
equal deleted inserted replaced
571:86d324061ddc 572:57018f21cd5c
30 open Mono 30 open Mono
31 31
32 structure EM = ErrorMsg 32 structure EM = ErrorMsg
33 structure E = MonoEnv 33 structure E = MonoEnv
34 structure U = MonoUtil 34 structure U = MonoUtil
35
36 val funcs = [(("Basis", "alert"), "alert"),
37 (("Basis", "htmlifyString"), "escape")]
38
39 structure FM = BinaryMapFn(struct
40 type ord_key = string * string
41 fun compare ((m1, x1), (m2, x2)) =
42 Order.join (String.compare (m1, m2),
43 fn () => String.compare (x1, x2))
44 end)
45
46 val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs
47
48 fun ffi k = FM.find (funcs, k)
35 49
36 type state = { 50 type state = {
37 decls : decl list, 51 decls : decl list,
38 script : string 52 script : string
39 } 53 }
68 | EDml _ => 0 82 | EDml _ => 0
69 | ENextval _ => 0 83 | ENextval _ => 0
70 | EUnurlify _ => 0 84 | EUnurlify _ => 0
71 | EJavaScript _ => 0 85 | EJavaScript _ => 0
72 | ESignalReturn e => varDepth e 86 | ESignalReturn e => varDepth e
87 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
73 88
74 fun strcat loc es = 89 fun strcat loc es =
75 case es of 90 case es of
76 [] => (EPrim (Prim.String ""), loc) 91 [] => (EPrim (Prim.String ""), loc)
77 | [x] => x 92 | [x] => x
148 strcat [str "{v:", e, str "}"] 163 strcat [str "{v:", e, str "}"]
149 else 164 else
150 e, st) 165 e, st)
151 end 166 end
152 167
153 | EFfi (_, s) => (str s, st) 168 | EFfi k =>
154 | EFfiApp (_, s, []) => (str (s ^ "()"), st) 169 let
155 | EFfiApp (_, s, [e]) => 170 val name = case ffi k of
156 let 171 NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript";
157 val (e, st) = jsE inner (e, st) 172 "ERROR")
158 173 | SOME s => s
159 in 174 in
160 (strcat [str (s ^ "("), 175 (str name, st)
161 e, 176 end
162 str ")"], st) 177 | EFfiApp (m, x, args) =>
163 end 178 let
164 | EFfiApp (_, s, e :: es) => 179 val name = case ffi (m, x) of
165 let 180 NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript";
166 val (e, st) = jsE inner (e, st) 181 "ERROR")
167 val (es, st) = ListUtil.foldlMapConcat 182 | SOME s => s
168 (fn (e, st) => 183 in
169 let 184 case args of
170 val (e, st) = jsE inner (e, st) 185 [] => (str (name ^ "()"), st)
171 in 186 | [e] =>
172 ([str ",", e], st) 187 let
173 end) 188 val (e, st) = jsE inner (e, st)
174 st es 189
175 in 190 in
176 (strcat (str (s ^ "(") 191 (strcat [str (name ^ "("),
177 :: e 192 e,
178 :: es 193 str ")"], st)
179 @ [str ")"]), st) 194 end
195 | e :: es =>
196 let
197 val (e, st) = jsE inner (e, st)
198 val (es, st) = ListUtil.foldlMapConcat
199 (fn (e, st) =>
200 let
201 val (e, st) = jsE inner (e, st)
202 in
203 ([str ",", e], st)
204 end)
205 st es
206 in
207 (strcat (str (name ^ "(")
208 :: e
209 :: es
210 @ [str ")"]), st)
211 end
180 end 212 end
181 213
182 | EApp (e1, e2) => 214 | EApp (e1, e2) =>
183 let 215 let
184 val (e1, st) = jsE inner (e1, st) 216 val (e1, st) = jsE inner (e1, st)
315 | EJavaScript _ => unsupported "Nested JavaScript" 347 | EJavaScript _ => unsupported "Nested JavaScript"
316 | ESignalReturn e => 348 | ESignalReturn e =>
317 let 349 let
318 val (e, st) = jsE inner (e, st) 350 val (e, st) = jsE inner (e, st)
319 in 351 in
320 (strcat [str "sreturn(", 352 (strcat [str "sr(",
321 e, 353 e,
354 str ")"],
355 st)
356 end
357 | ESignalBind (e1, e2) =>
358 let
359 val (e1, st) = jsE inner (e1, st)
360 val (e2, st) = jsE inner (e2, st)
361 in
362 (strcat [str "sb(",
363 e1,
364 str ",",
365 e2,
322 str ")"], 366 str ")"],
323 st) 367 st)
324 end 368 end
325 end 369 end
326 in 370 in