Support @new @variadic

Signed-off-by: Yuta Sato <[email protected]>

Author: cannorin

jscomp/core/lam_compile_external_call.ml

@@ -30,6 +30,10 @@ let splice_fn_apply fn args =
   E.runtime_call Js_runtime_modules.caml_splice_call "spliceApply"
     [ fn; E.array Immutable args ]
 
+let splice_fn_new_apply fn args =
+  E.runtime_call Js_runtime_modules.caml_splice_call "spliceNewApply"
+    [ fn; E.array Immutable args ]
+
 let splice_obj_fn_apply obj name args =
   E.runtime_call Js_runtime_modules.caml_splice_call "spliceObjApply"
     [ obj; E.str name; E.array Immutable args ]
@@ -271,7 +275,7 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
         let args, eff = assemble_args_no_splice arg_types args in
         (* TODO: fix in rest calling convention *)
         add_eff eff (E.call ~info:{ arity = Full; call_info = Call_na } fn args)
-  | Js_new { external_module_name = module_name; name = fn; scopes } ->
+  | Js_new { external_module_name = module_name; name = fn; splice; scopes } ->
       (* handle [@@new]*)
       (* This has some side effect, it will
          mark its identifier (If it has) as an object,
@@ -281,15 +285,24 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
          TODO: we should propagate this property
          as much as we can(in alias table)
       *)
-      let args, eff = assemble_args_no_splice arg_types args in
-      let fn = translate_scoped_module_val module_name fn scopes in
-      add_eff eff
-        ((match cxt.continuation with
+      let mark () =
+        match cxt.continuation with
          | Declare (_, id) | Assign id ->
              (* Format.fprintf Format.err_formatter "%a@."Ident.print  id; *)
              Ext_ident.make_js_object id
-         | EffectCall _ | NeedValue _ -> ());
-         E.new_ fn args)
+        | EffectCall _ | NeedValue _ -> ()
+      in
+      let fn = translate_scoped_module_val module_name fn scopes in
+      if splice then
+        let args, eff, dynamic = assemble_args_has_splice arg_types args in
+        add_eff eff
+          (mark ();
+          if dynamic then splice_fn_new_apply fn args
+          else E.new_ fn args)
+      else
+        let args, eff = assemble_args_no_splice arg_types args in
+        add_eff eff
+          (mark (); E.new_ fn args)
   | Js_send { splice; name; js_send_scopes } -> (
       match args with
       | self :: args ->

jscomp/frontend/ast_external_process.ml

@@ -800,12 +800,12 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
    val_send = None;
    set_name = None;
    get_name = None;
-   splice = false;
+   splice;
    scopes;
    mk_obj = _;
    return_wrapper = _;
   } ->
-      Js_new { name; external_module_name; scopes }
+      Js_new { name; external_module_name; splice; scopes }
   | { new_name = Some _; _ } ->
       Bs_syntaxerr.err loc
         (Conflict_ffi_attribute "Attribute found that conflicts with %@new")

jscomp/frontend/external_ffi_types.mli

@@ -58,6 +58,7 @@ type external_spec =
   | Js_new of {
       name : string;
       external_module_name : external_module_name option;
+      splice : bool;
       scopes : string list;
     }
   | Js_set of { js_set_name : string; js_set_scopes : string list }

jscomp/frontend/external_ffi_types.pp.ml

@@ -71,6 +71,7 @@ type external_spec =
   | Js_new of {
       name : string ;
       external_module_name : external_module_name option;
+      splice : bool ;
       scopes : string list;
     }
   | Js_set of { 
@@ -223,7 +224,7 @@ let check_ffi ?loc ffi : bool =
       -> 
       upgrade (is_package_relative_path external_module_name.bundle);
       check_external_module_name external_module_name
-    | Js_new {external_module_name ;  name; scopes = _}
+    | Js_new {external_module_name ;  name; splice = _; scopes = _}
     | Js_call {external_module_name ;  name ; splice = _; scopes = _ }
       ->
       Ext_option.iter external_module_name (fun external_module_name ->

jscomp/runtime/caml_splice_call.ml

@@ -38,6 +38,20 @@ let spliceApply : obj -> obj -> obj = [%raw{|function(fn,args){
   return fn.apply(null,applied)
 }|}] 
 
+let spliceNewApply : obj -> obj -> obj = [%raw{|function (ctor,args){
+  var i, argLen;
+  argLen = args.length
+  var applied = []
+  for(i = 0; i < argLen - 1; ++i){
+    applied.push(args[i])
+  }
+  var lastOne = args[argLen - 1]
+  for(i = 0; i < lastOne.length; ++i ){
+    applied.push(lastOne[i])
+  }
+  return new ctor(...applied)
+}|}]
+
 let spliceObjApply : obj -> obj -> obj -> obj = [%raw{|function(obj,name,args){
   var i, argLen; 
   argLen = args.length

jscomp/runtime/caml_splice_call.mli

@@ -27,4 +27,6 @@ type obj = Obj.t
 
 val spliceApply : obj -> obj -> obj
 
+val spliceNewApply : obj -> obj -> obj
+
 val spliceObjApply : obj -> obj -> obj -> obj

jscomp/test/splice_test.ml

@@ -37,6 +37,25 @@ let dynamic arr =
 ;; dynamic [||]
 ;; dynamic [|1;1;3|]
 
+(* Array constructor with a single parameter `x`
+   just makes an array with its length set to `x`,
+   so at least two parameters are needed
+*)
+external newArr : int -> int -> int array -> int array = "Array"
+  [@@bs.splice] [@@bs.new]
+
+let () =
+  let a = newArr 1 2 [|3;4|] in
+  eq __LOC__ a [|1;2;3;4|]
+
+let dynamicNew arr =
+  let a = newArr 1 2 arr in
+  eq __LOC__ a (Array.concat [[|1; 2|]; arr])
+
+;; dynamicNew [|3;4|]
+;; dynamicNew [||]
+;; dynamicNew [|1;3|]
+
 module Pipe = struct
   external push :  int array -> int -> int array -> unit = 
     "push" [@@send] [@@bs.splice]