Mercurial > urweb

comparison src/jscomp.sml @ 910:8e540df3294d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
grid1 compiles but gets stuck in JS
author Adam Chlipala <adamc@hcoop.net>
date Tue, 25 Aug 2009 13:57:56 -0400
parents c270fb847dc2
children 12c77dc567a2
comparison
equal deleted inserted replaced
909:1d3f60e74ec7 910:8e540df3294d
84 | EUnurlify _ => 0 84 | EUnurlify _ => 0
85 | EJavaScript _ => 0 85 | EJavaScript _ => 0
86 | ESignalReturn e => varDepth e 86 | ESignalReturn e => varDepth e
87 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) 87 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
88 | ESignalSource e => varDepth e 88 | ESignalSource e => varDepth e
89 | EServerCall (e, ek, _, _, _) => Int.max (varDepth e, varDepth ek) 89 | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek)
90 | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek) 90 | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
91 | ESleep (e, ek) => Int.max (varDepth e, varDepth ek) 91 | ESleep (e, ek) => Int.max (varDepth e, varDepth ek)
92 92
93 fun closedUpto d = 93 fun closedUpto d =
94 let 94 let
128 | EUnurlify (e, _) => cu inner e 128 | EUnurlify (e, _) => cu inner e
129 | EJavaScript (_, e) => cu inner e 129 | EJavaScript (_, e) => cu inner e
130 | ESignalReturn e => cu inner e 130 | ESignalReturn e => cu inner e
131 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 131 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
132 | ESignalSource e => cu inner e 132 | ESignalSource e => cu inner e
133 | EServerCall (e, ek, _, _, _) => cu inner e andalso cu inner ek 133 | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek
134 | ERecv (e, ek, _) => cu inner e andalso cu inner ek 134 | ERecv (e, ek, _) => cu inner e andalso cu inner ek
135 | ESleep (e, ek) => cu inner e andalso cu inner ek 135 | ESleep (e, ek) => cu inner e andalso cu inner ek
136 in 136 in
137 cu 0 137 cu 0
138 end 138 end
387 raise CantEmbed t) 387 raise CantEmbed t)
388 388
389 fun unurlifyExp loc (t : typ, st) = 389 fun unurlifyExp loc (t : typ, st) =
390 case #1 t of 390 case #1 t of
391 TRecord [] => ("null", st) 391 TRecord [] => ("null", st)
392 | TFfi ("Basis", "unit") => ("null", st)
392 | TRecord [(x, t)] => 393 | TRecord [(x, t)] =>
393 let 394 let
394 val (e, st) = unurlifyExp loc (t, st) 395 val (e, st) = unurlifyExp loc (t, st)
395 in 396 in
396 ("{_" ^ x ^ ":" ^ e ^ "}", 397 ("{_" ^ x ^ ":" ^ e ^ "}",
522 | PConFfi {mod = "Basis", con = "False", ...} => str "false" 523 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
523 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") 524 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
524 525
525 fun unsupported s = 526 fun unsupported s =
526 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); 527 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
528 Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e);
527 (str "ERROR", st)) 529 (str "ERROR", st))
528 530
529 val strcat = strcat loc 531 val strcat = strcat loc
530 532
531 fun jsPrim p = 533 fun jsPrim p =
667 | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\"" 669 | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
668 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; 670 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
669 raise Fail "Jscomp: deStrcat") 671 raise Fail "Jscomp: deStrcat")
670 672
671 val quoteExp = quoteExp loc 673 val quoteExp = quoteExp loc
674
675 val hasQuery = U.Exp.exists {typ = fn _ => false,
676 exp = fn EQuery _ => true
677 | _ => false}
678
679 val indirectQuery = U.Exp.exists {typ = fn _ => false,
680 exp = fn ENamed n =>
681 (case IM.find (nameds, n) of
682 NONE => false
683 | SOME e => hasQuery e)
684 | _ => false}
685
672 in 686 in
687 (*if indirectQuery e then
688 Print.preface ("Indirect", MonoPrint.p_exp MonoEnv.empty e)
689 else
690 ();*)
691
673 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e), 692 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
674 ("inner", Print.PD.string (Int.toString inner))];*) 693 ("inner", Print.PD.string (Int.toString inner))];*)
675 694
676 case #1 e of 695 case #1 e of
677 EPrim p => (jsPrim p, st) 696 EPrim p => (jsPrim p, st)
1039 e, 1058 e,
1040 str ")"], 1059 str ")"],
1041 st) 1060 st)
1042 end 1061 end
1043 1062
1044 | EServerCall (e, ek, t, eff, _) => 1063 | EServerCall (e, ek, t, eff) =>
1045 let 1064 let
1046 val (e, st) = jsE inner (e, st) 1065 val (e, st) = jsE inner (e, st)
1047 val (ek, st) = jsE inner (ek, st) 1066 val (ek, st) = jsE inner (ek, st)
1048 val (unurl, st) = unurlifyExp loc (t, st) 1067 val (unurl, st) = unurlifyExp loc (t, st)
1049 in 1068 in
1318 val (e, st) = exp outer (e, st) 1337 val (e, st) = exp outer (e, st)
1319 in 1338 in
1320 ((ESignalSource e, loc), st) 1339 ((ESignalSource e, loc), st)
1321 end 1340 end
1322 1341
1323 | EServerCall (e1, e2, t, ef, ue) => 1342 | EServerCall (e1, e2, t, ef) =>
1324 let 1343 let
1325 val (e1, st) = exp outer (e1, st) 1344 val (e1, st) = exp outer (e1, st)
1326 val (e2, st) = exp outer (e2, st) 1345 val (e2, st) = exp outer (e2, st)
1327 val (ue, st) = exp outer (ue, st) 1346 in
1328 in 1347 ((EServerCall (e1, e2, t, ef), loc), st)
1329 ((EServerCall (e1, e2, t, ef, ue), loc), st)
1330 end 1348 end
1331 | ERecv (e1, e2, t) => 1349 | ERecv (e1, e2, t) =>
1332 let 1350 let
1333 val (e1, st) = exp outer (e1, st) 1351 val (e1, st) = exp outer (e1, st)
1334 val (e2, st) = exp outer (e2, st) 1352 val (e2, st) = exp outer (e2, st)