diff src/jscomp.sml @ 910:8e540df3294d

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
line wrap: on
line diff
--- a/src/jscomp.sml	Sat Aug 22 16:32:31 2009 -0400
+++ b/src/jscomp.sml	Tue Aug 25 13:57:56 2009 -0400
@@ -86,7 +86,7 @@
       | ESignalReturn e => varDepth e
       | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
       | ESignalSource e => varDepth e
-      | EServerCall (e, ek, _, _, _) => Int.max (varDepth e, varDepth ek)
+      | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek)
       | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
       | ESleep (e, ek) => Int.max (varDepth e, varDepth ek)
 
@@ -130,7 +130,7 @@
               | ESignalReturn e => cu inner e
               | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
               | ESignalSource e => cu inner e
-              | EServerCall (e, ek, _, _, _) => cu inner e andalso cu inner ek
+              | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek
               | ERecv (e, ek, _) => cu inner e andalso cu inner ek
               | ESleep (e, ek) => cu inner e andalso cu inner ek
     in
@@ -389,6 +389,7 @@
         fun unurlifyExp loc (t : typ, st) =
             case #1 t of
                 TRecord [] => ("null", st)
+              | TFfi ("Basis", "unit") => ("null", st)
               | TRecord [(x, t)] =>
                 let
                     val (e, st) = unurlifyExp loc (t, st)
@@ -524,6 +525,7 @@
 
                         fun unsupported s =
                             (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
+                             Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e);
                              (str "ERROR", st))
 
                         val strcat = strcat loc
@@ -669,7 +671,24 @@
                                       raise Fail "Jscomp: deStrcat")
 
                         val quoteExp = quoteExp loc
+
+                        val hasQuery = U.Exp.exists {typ = fn _ => false,
+                                                     exp = fn EQuery _ => true
+                                                            | _ => false}
+
+                        val indirectQuery = U.Exp.exists {typ = fn _ => false,
+                                                          exp = fn ENamed n =>
+                                                                   (case IM.find (nameds, n) of
+                                                                        NONE => false
+                                                                      | SOME e => hasQuery e)
+                                                                 | _ => false}
+
                     in
+                        (*if indirectQuery e then
+                            Print.preface ("Indirect", MonoPrint.p_exp MonoEnv.empty e)
+                        else
+                            ();*)
+
                         (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
                                               ("inner", Print.PD.string (Int.toString inner))];*)
 
@@ -1041,7 +1060,7 @@
                                  st)
                             end
 
-                          | EServerCall (e, ek, t, eff, _) =>
+                          | EServerCall (e, ek, t, eff) =>
                             let
                                 val (e, st) = jsE inner (e, st)
                                 val (ek, st) = jsE inner (ek, st)
@@ -1320,13 +1339,12 @@
                      ((ESignalSource e, loc), st)
                  end
                  
-               | EServerCall (e1, e2, t, ef, ue) =>
+               | EServerCall (e1, e2, t, ef) =>
                  let
                      val (e1, st) = exp outer (e1, st)
                      val (e2, st) = exp outer (e2, st)
-                     val (ue, st) = exp outer (ue, st)
                  in
-                     ((EServerCall (e1, e2, t, ef, ue), loc), st)
+                     ((EServerCall (e1, e2, t, ef), loc), st)
                  end
                | ERecv (e1, e2, t) =>
                  let