diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml
index cee57a07b2e28e5fc6dba36248f8820040f482d3..5d3d5cbcb9437a1dce0681b5c38ea652752c8dbe 100644
--- a/generator/js_of_ast.ml
+++ b/generator/js_of_ast.ml
@@ -71,12 +71,19 @@ let is_infix f args = match args with
let args_loc = (x.exp_loc.loc_start, x.exp_loc.loc_end) in
if fst args_loc < fst f_loc then true else false
-let map_cstr_fields ?loc f (cstr : constructor_description) elements =
+let map_cstr_fields ?loc bind (cstr : constructor_description) elements =
let fields = extract_cstr_attrs cstr in
- try List.map2 f fields elements
- with Invalid_argument _ -> error ?loc ("Insufficient fieldnames for arguments to " ^ cstr.cstr_name)
-
-
+ let rec aux = function
+ | [], [] -> []
+ | f :: fs, e :: es ->
+ let res = aux (fs,es) in
+ begin match bind e f with
+ | None -> res
+ | Some p -> p :: res (* p is a pair identifier, code to be bound *)
+ end
+ | _ -> error ?loc ("Insufficient fieldnames for arguments to " ^ cstr.cstr_name)
+ in aux (fields, elements)
+
(****************************************************************)
(* PPF HELPERS *)
@@ -119,7 +126,7 @@ let ppf_match_case c =
Printf.sprintf "case %s" c
let ppf_match_binders binders =
- let binds = show_list ", " (List.map (fun (id,se) -> Print.sprintf "%s = %s" id se) binders) in
+ let binds = show_list ", " (List.map (fun (id,se) -> Printf.sprintf "%s = %s" id se) binders) in
Printf.sprintf "@[<v 0>var %s;@]" binds
let ppf_array values =
@@ -212,9 +219,9 @@ let ppf_module_wrap name content =
(****************************************************************)
(* FRESH ID NAMES *)
-let id_fresh prefix =
+let id_fresh =
let r = ref 0 in
- fun () -> (incr r; prefix ^ string_of_int !r)
+ fun prefix -> (incr r; prefix ^ string_of_int !r)
(****************************************************************)
@@ -347,14 +354,14 @@ may reuse
type dest =
| Dest_ignore
| Dest_return
- | Dest_assign of id
+ | Dest_assign of string
| Dest_inline
-let apply_dest dest sbody =
+let apply_dest ctx dest sbody =
match dest with
| Dest_ignore -> sbody
| Dest_return -> generate_logged_return ctx sbody
- | Dest_assign id -> Printf.sprintf "var %s = %s;" (ppf_ident id) sbody
+ | Dest_assign id -> Printf.sprintf "var %s = %s;" id sbody
| Dest_inline -> sbody
(* LATER: pull out the "var" out of switch *)
@@ -387,7 +394,7 @@ and show_value_binding ctx vb = (* dest is Ignore *)
and js_of_structure_item s =
let loc = s.str_loc in
match s.str_desc with
- | Tstr_eval (e, _) -> Printf.sprintf "%s" @@ js_of_expression ctx_initial Dest_ignore initial_dest e
+ | Tstr_eval (e, _) -> Printf.sprintf "%s" @@ js_of_expression ctx_initial Dest_ignore e
| Tstr_value (_, vb_l) -> String.concat "@,@," @@ List.map (fun vb ->
let (id, sdecl) = show_value_binding ctx_initial vb in
sdecl) @@ vb_l
@@ -420,18 +427,18 @@ and js_of_expression_inline_or_wrap ctx e =
and js_of_expression_wrapped ctx e = (* dest = Dest_return *)
ppf_lambda_wrap (js_of_expression ctx Dest_return e)
-and js_of_expression ctx dest =
+and js_of_expression ctx dest e =
let inline_of_wrap = js_of_expression_inline_or_wrap ctx in (* shorthand *)
let loc = e.exp_loc in
match e.exp_desc with
| Texp_ident (_, ident, _) ->
let sexp = js_of_longident ident in
- apply_dest dest sexp
+ apply_dest ctx dest sexp
| Texp_constant c ->
let sexp = js_of_constant c in
- apply_dest dest sexp
+ apply_dest ctx dest sexp
| Texp_let (_, vb_l, e) ->
reject_inline dest;
@@ -440,7 +447,7 @@ and js_of_expression ctx dest =
let newctx = ctx_fresh() in
let sbody = js_of_expression newctx dest e in
let sexp = generate_logged_let ids ctx newctx sdecl sbody in
- apply_dest dest sexp
+ apply_dest ctx dest sexp
| Texp_function (_, c :: [], Total) ->
let rec explore pats e = match e.exp_desc with
@@ -455,7 +462,7 @@ and js_of_expression ctx dest =
let newdest = Dest_return in
let sbody = js_of_expression newctx newdest body in
let sexp = generate_logged_enter arg_ids ctx newctx sbody in
- apply_dest dest sexp
+ apply_dest ctx dest sexp
| Texp_apply (f, exp_l) ->
let sl' = exp_l (* only used to know if infix *)
@@ -473,7 +480,7 @@ and js_of_expression ctx dest =
then ppf_apply_infix se (List.hd sl) (List.hd (List.tl sl))
else ppf_apply se (String.concat ", " sl)
in
- apply_dest dest sexp
+ apply_dest ctx dest sexp
| Texp_match (exp, l, [], Total) ->
reject_inline dest;
@@ -483,17 +490,17 @@ and js_of_expression ctx dest =
"", (js_of_longident ident)
| _ -> (* generate var id = sexp; *)
let id = id_fresh "_switch_arg_" in
- let sdecl = js_of_expression (Dest_assign id) ctx exp in
- sdecl, id
+ let sintro = js_of_expression ctx (Dest_assign id) exp in
+ (sintro ^ "@,"), id
in
let sb = String.concat "@," (List.map (fun b -> js_of_branch ctx dest b seobj) l) in
let const = exp_type_is_constant exp in
- let sexp = ppf_match se sb const in
- apply_dest dest sexp
+ let sexp = sintro ^ (ppf_match seobj sb const) in
+ apply_dest ctx dest sexp
| Texp_tuple (tl) ->
let sexp = ppf_tuple @@ show_list_f (fun exp -> inline_of_wrap exp) ", " tl in
- apply_dest dest sexp
+ apply_dest ctx dest sexp
| Texp_construct (_, cd, el) ->
let name = cd.cstr_name in
@@ -506,7 +513,7 @@ and js_of_expression ctx dest =
let expanded_constructors = map_cstr_fields ~loc ppf_cstr cd expr_strs in
ppf_multiple_cstrs name (show_list ", " expanded_constructors)
in
- apply_dest dest sexp
+ apply_dest ctx dest sexp
| Texp_array (exp_l) -> ppf_array @@ show_list_f (fun exp -> inline_of_wrap exp) ", " exp_l
| Texp_ifthenelse (e1, e2, None) -> out_of_scope loc "if without else"
@@ -565,7 +572,7 @@ and js_of_let_pattern ctx pat expr =
| Tpat_var (id, _) -> id
| _ -> error ~loc:pat.pat_loc "let can't deconstruct values"
in
- (id, js_of_expression ctx (Dest_assign id) expr)
+ (id, js_of_expression ctx (Dest_assign (ppf_ident id)) expr)
(* LATER: for let (x,y) = e, encode as translate(e,assign z); x = z[0]; y=z[1]
| Tpat_tuple (pat_l)
@@ -596,8 +603,8 @@ and js_of_pattern pat obj =
let bind field var =
match var.pat_desc with
| Tpat_var (id, _) ->
- (ppf_ident id, Printf.sprintf "%s.%s" obj field)
- | Tpat_any -> []
+ Some (ppf_ident id, Printf.sprintf "%s.%s" obj field)
+ | Tpat_any -> None
| _ -> out_of_scope var.pat_loc "Nested pattern matching"
in
let binders = map_cstr_fields ~loc bind cd el in
@@ -705,4 +712,4 @@ translates as
=>
requires A-normalization
-*)
\ No newline at end of file
+*)