stack traces (loooong error messages on uncaught exceptions for now)

src/ljs/ljs_eval.ml

@@ -180,7 +180,14 @@ let rec set_attr (store : store) attr obj field newval = match obj, field with
 
 
 let rec eval jsonPath exp env (store : store) : (value * store) =
-  let eval = eval jsonPath in
+  let eval exp env store =
+    begin try eval jsonPath exp env store
+      with 
+      | Break (exprs, l, v, s) ->
+        raise (Break (exp::exprs, l, v, s))
+      | Throw (exprs, v, s) ->
+        raise (Throw (exp::exprs, v, s))
+    end in
   match exp with
   | S.Hint (_, _, e) -> eval e env store
   | S.Undefined _ -> Undefined, store
@@ -439,13 +446,13 @@ let rec eval jsonPath exp env (store : store) : (value * store) =
       begin
         try
           eval e env store
-        with Break (_, l', v, store) ->
+        with Break (t, l', v, store) ->
           if l = l' then (v, store)
-          else raise (Break (p, l', v, store))
+          else raise (Break (t, l', v, store))
       end
   | S.Break (p, l, e) ->
       let v, store = eval e env store in
-      raise (Break (p, l, v, store))
+      raise (Break ([], l, v, store))
   | S.TryCatch (p, body, catch) -> begin
       try
         eval body env store
@@ -458,15 +465,15 @@ let rec eval jsonPath exp env (store : store) : (value * store) =
         let (_, store) = eval body env store in
         eval fin env store
       with
-        | Throw (p, v, store) ->
+        | Throw (t, v, store) ->
           let (_, store) = eval fin env store in
-          raise (Throw (p, v, store))
-        | Break (p, l, v, store) ->
+          raise (Throw (t, v, store))
+        | Break (t, l, v, store) ->
           let (_, store) = eval fin env store in
-          raise (Break (p, l, v, store))
+          raise (Break (t, l, v, store))
       end
   | S.Throw (p, e) -> let (v, s) = eval e env store in
-    raise (Throw (p, v, s))
+    raise (Throw ([], v, s))
   | S.Lambda (p, xs, e) -> 
     let alloc_arg argval argname (store, env) =
       let (new_loc, store) = add_var store argval in
@@ -480,10 +487,10 @@ let rec eval jsonPath exp env (store : store) : (value * store) =
         eval e env store in
     Closure closure, store
   | S.Eval (p, e) ->
-    match eval e env store with
-      | String s, store -> eval_op p s env store jsonPath
+    begin match eval e env store with
+      | String s, store -> eval_op s env store jsonPath
       | v, store -> v, store
-
+    end
 
 and arity_mismatch_err p xs args = failwith ("Arity mismatch, supplied " ^ string_of_int (List.length args) ^ " arguments and expected " ^ string_of_int (List.length xs) ^ " at " ^ string_of_position p ^ ". Arg names were: " ^ (List.fold_right (^) (map (fun s -> " " ^ s ^ " ") xs) "") ^ ". Values were: " ^ (List.fold_right (^) (map (fun v -> " " ^ pretty_value v ^ " ") args) ""))
 
@@ -494,7 +501,7 @@ and arity_mismatch_err p xs args = failwith ("Arity mismatch, supplied " ^ strin
    only a single file works out. 
 
    TODO(joe): I have no idea what happens on windows. *)
-and eval_op p str env store jsonPath = 
+and eval_op str env store jsonPath = 
   let outchan = open_out "/tmp/curr_eval.js" in
   output_string outchan str;
   close_out outchan;
@@ -507,15 +514,15 @@ and eval_op p str env store jsonPath =
   let json_err = regexp (quote "SyntaxError") in
   begin try
     ignore (search_forward json_err buf 0);
-    raise (Throw (p, String "EvalError", store))
+    raise (Throw ([], String "EvalError", store))
     with Not_found -> ()
   end;
   let ast =
     parse_spidermonkey (open_in "/tmp/curr_eval.json") "/tmp/curr_eval.json" in
   let (used_ids, exprjsd) = 
     try
       js_to_exprjs ast (Exprjs_syntax.IdExpr (dummy_pos, "%global"))
-    with ParseError _ -> raise (Throw (p, String "EvalError", store))
+    with ParseError _ -> raise (Throw ([], String "EvalError", store))
     in
   let desugard = exprjs_to_ljs used_ids exprjsd in
   if (IdMap.mem "%global" env) then
@@ -527,7 +534,7 @@ and eval_op p str env store jsonPath =
 let rec eval_expr expr jsonPath = try
   eval jsonPath expr IdMap.empty (Store.empty, Store.empty)
 with
-  | Throw (p, v, store) ->
+  | Throw (t, v, store) ->
       let err_msg = 
         match v with
           | ObjLoc loc ->
@@ -540,6 +547,7 @@ with
                 with Not_found -> string_of_value v store
                 end
           | v -> (pretty_value v) in
-        failwith (sprintf "%s Uncaught exception: %s" (Pos.string_of_pos p) err_msg)
+        printf "%s\nUncaught exception: %s\n" (string_stack_trace t) err_msg;
+        failwith "Uncaught exception"
   | Break (p, l, v, _) -> failwith ("Broke to top of execution, missed label: " ^ l)
 

src/ljs/ljs_pretty.ml

@@ -114,3 +114,9 @@ and prop (f, prop) = match prop with
                                           horz[text "#setter";
                                                exp s]])]
 
+let stack_trace exprs =
+  vert (map (fun expr -> text (string_of_position (pos_of expr))) exprs)
+
+let string_stack_trace =
+  FormatExt.to_string stack_trace
+

src/ljs/ljs_values.ml

@@ -54,8 +54,8 @@ let add_var (objs, vars) new_val =
 type env = Store.loc IdMap.t
 type label = string
 
-exception Break of pos * label * value * store
-exception Throw of pos * value * store
+exception Break of exp list * label * value * store
+exception Throw of exp list * value * store
 
 let pretty_value v = match v with 
   | Num d -> string_of_float d