Mercurial > urweb

comparison src/jscomp.sml @ 801:5f49a6b759cb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix nasty bugs with longjmp() looping for uw_set_input(); and bad variable indexes for nested JavaScript in jscomp
author Adam Chlipala <adamc@hcoop.net>
date Thu, 14 May 2009 18:13:09 -0400
parents e92cfac1608f
children d8f58d488cfb
comparison
equal deleted inserted replaced
800:e92cfac1608f 801:5f49a6b759cb
141 case es of 141 case es of
142 [] => (EPrim (Prim.String ""), loc) 142 [] => (EPrim (Prim.String ""), loc)
143 | [x] => x 143 | [x] => x
144 | x :: es' => (EStrcat (x, strcat loc es'), loc) 144 | x :: es' => (EStrcat (x, strcat loc es'), loc)
145 145
146 fun patDepth (p, _) =
147 case p of
148 PWild => 0
149 | PVar _ => 0
150 | PPrim _ => 0
151 | PCon (_, _, NONE) => 0
152 | PCon (_, _, SOME p) => 1 + patDepth p
153 | PRecord xpts => foldl Int.max 0 (map (fn (_, p, _) => 1 + patDepth p) xpts)
154 | PNone _ => 0
155 | PSome (_, p) => 1 + patDepth p
156
157 val compact =
158 U.Exp.mapB {typ = fn t => t,
159 exp = fn inner => fn e =>
160 case e of
161 ERel n =>
162 if n >= inner then
163 ERel (n - inner)
164 else
165 e
166 | _ => e,
167 bind = fn (inner, b) =>
168 case b of
169 U.Exp.RelE _ => inner+1
170 | _ => inner}
171
146 fun process file = 172 fun process file =
147 let 173 let
148 val (someTs, nameds) = 174 val (someTs, nameds) =
149 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) 175 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
150 | ((DValRec vis, _), (someTs, nameds)) => 176 | ((DValRec vis, _), (someTs, nameds)) =>
252 listInjectors = TM.insert (#listInjectors st, t', n'), 278 listInjectors = TM.insert (#listInjectors st, t', n'),
253 decoders = #decoders st, 279 decoders = #decoders st,
254 maxName = n' + 1} 280 maxName = n' + 1}
255 281
256 val s = (TFfi ("Basis", "string"), loc) 282 val s = (TFfi ("Basis", "string"), loc)
257 val (e', st) = quoteExp loc t ((EField ((ERel 0, loc), "1"), loc), st) 283 val (e', st) = quoteExp loc t' ((EField ((ERel 0, loc), "1"), loc), st)
258 284
259 val body = (ECase ((ERel 0, loc), 285 val body = (ECase ((ERel 0, loc),
260 [((PNone rt, loc), 286 [((PNone rt, loc),
261 str loc "null"), 287 str loc "null"),
262 ((PSome (rt, (PVar ("x", rt), loc)), loc), 288 ((PSome (rt, (PVar ("x", rt), loc)), loc),
618 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; 644 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
619 raise Fail "Jscomp: deStrcat") 645 raise Fail "Jscomp: deStrcat")
620 646
621 val quoteExp = quoteExp loc 647 val quoteExp = quoteExp loc
622 in 648 in
623 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*) 649 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
650 ("inner", Print.PD.string (Int.toString inner))];*)
624 651
625 case #1 e of 652 case #1 e of
626 EPrim p => (jsPrim p, st) 653 EPrim p => (jsPrim p, st)
627 | ERel n => 654 | ERel n =>
628 if n < inner then 655 if n < inner then
629 (str ("_" ^ var n), st) 656 (str ("_" ^ var n), st)
630 else 657 else
631 let 658 let
659 (*val () = Print.prefaces "ERel"
660 [("n", Print.PD.string (Int.toString n)),
661 ("inner", Print.PD.string (Int.toString inner)),
662 ("eq", MonoPrint.p_exp MonoEnv.empty
663 (#1 (quoteExp (List.nth (outer, n - inner))
664 ((ERel (n - inner), loc), st))))]*)
632 val n = n - inner 665 val n = n - inner
633 in 666 in
634 quoteExp (List.nth (outer, n)) ((ERel n, loc), st) 667 quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
635 end 668 end
636 669
650 injectors = #injectors st, 683 injectors = #injectors st,
651 listInjectors = #listInjectors st, 684 listInjectors = #listInjectors st,
652 decoders = #decoders st, 685 decoders = #decoders st,
653 maxName = #maxName st} 686 maxName = #maxName st}
654 687
688 val old = e
655 val (e, st) = jsExp mode [] 0 (e, st) 689 val (e, st) = jsExp mode [] 0 (e, st)
690 val new = e
656 val e = deStrcat 0 e 691 val e = deStrcat 0 e
657 692
658 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" 693 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
659 in 694 in
695 (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old),
696 ("new", MonoPrint.p_exp MonoEnv.empty new)];*)
660 {decls = #decls st, 697 {decls = #decls st,
661 script = sc :: #script st, 698 script = sc :: #script st,
662 included = #included st, 699 included = #included st,
663 injectors = #injectors st, 700 injectors = #injectors st,
664 listInjectors = #listInjectors st, 701 listInjectors = #listInjectors st,
849 (strcat [e, 886 (strcat [e,
850 str ("._" ^ x)], st) 887 str ("._" ^ x)], st)
851 end 888 end
852 889
853 | ECase (e', pes, {result, ...}) => 890 | ECase (e', pes, {result, ...}) =>
854 (*if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then 891 let
855 let 892 val plen = length pes
856 val (e', st) = quoteExp result ((ERel 0, loc), st) 893
857 in 894 val (cases, st) = ListUtil.foldliMap
858 ((ELet ("js", result, e, e'), loc), 895 (fn (i, (p, e), st) =>
859 st) 896 let
860 end 897 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
861 else*) 898 val fail =
862 let 899 if i = plen - 1 then
863 val plen = length pes 900 str "pf()"
864 901 else
865 val (cases, st) = ListUtil.foldliMap 902 str ("c" ^ Int.toString (i+1) ^ "()")
866 (fn (i, (p, e), st) => 903 val c = jsPat 0 inner p e fail
867 let 904 in
868 val (e, st) = jsE (inner + E.patBindsN p) (e, st) 905 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
869 val fail = 906 c,
870 if i = plen - 1 then 907 str "},"],
871 str "pf()" 908 st)
872 else 909 end)
873 str ("c" ^ Int.toString (i+1) ^ "()") 910 st pes
874 val c = jsPat 0 inner p e fail 911
875 in 912 val depth = foldl Int.max 0 (map (fn (p, _) => 1 + patDepth p) pes)
876 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), 913 val normalDepth = foldl Int.max 0 (map (fn (_, e) => 1 + varDepth e) pes)
877 c, 914 val (e, st) = jsE inner (e', st)
878 str "},"], 915
879 st) 916 val len = inner + len
880 end) 917 val normalVars = List.tabulate (normalDepth, fn n => "_" ^ Int.toString (n + len))
881 st pes 918 val patVars = List.tabulate (depth, fn n => "d" ^ Int.toString n)
882 919 in
883 val (e, st) = jsE inner (e', st) 920 (strcat (str "(function (){ var "
884 in 921 :: str (String.concatWith "," (normalVars @ patVars) ^ ";d0=")
885 (strcat (str "(d0=" 922 :: e
886 :: e 923 :: str ";\nreturn ("
887 :: str "," 924 :: List.revAppend (cases,
888 :: List.revAppend (cases, 925 [str "c0()) } ())"])), st)
889 [str "c0())"])), st) 926 end
890 end
891 927
892 | EStrcat (e1, e2) => 928 | EStrcat (e1, e2) =>
893 let 929 let
894 val (e1, st) = jsE inner (e1, st) 930 val (e1, st) = jsE inner (e1, st)
895 val (e2, st) = jsE inner (e2, st) 931 val (e2, st) = jsE inner (e2, st)
937 (foundJavaScript := true; 973 (foundJavaScript := true;
938 (e, st)) 974 (e, st))
939 | EJavaScript (_, _, SOME e) => 975 | EJavaScript (_, _, SOME e) =>
940 (foundJavaScript := true; 976 (foundJavaScript := true;
941 (strcat [str "cs(function(){return ", 977 (strcat [str "cs(function(){return ",
942 e, 978 compact inner e,
943 str "})"], 979 str "})"],
944 st)) 980 st))
945 981
946 | EClosure _ => unsupported "EClosure" 982 | EClosure _ => unsupported "EClosure"
947 | EQuery _ => unsupported "Query" 983 | EQuery _ => unsupported "Query"
1052 fun str s = (EPrim (Prim.String s), #2 e) 1088 fun str s = (EPrim (Prim.String s), #2 e)
1053 1089
1054 val locals = List.tabulate 1090 val locals = List.tabulate
1055 (varDepth e, 1091 (varDepth e,
1056 fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) 1092 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
1093 val old = e
1057 val (e, st) = jsExp m env 0 (e, st) 1094 val (e, st) = jsExp m env 0 (e, st)
1058 in 1095 in
1096 (*Print.prefaces "jsify" [("old", MonoPrint.p_exp MonoEnv.empty old),
1097 ("new", MonoPrint.p_exp MonoEnv.empty e)];*)
1059 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) 1098 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
1060 end 1099 end
1061 in 1100 in
1062 case e of 1101 case e of
1063 EJavaScript (m, orig, NONE) => 1102 EJavaScript (m, orig, NONE) =>