Support @new @variadic

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

Author: cannorin

jscomp/core/lam_compile_external_call.ml

@@ -1,5 +1,5 @@
 (* Copyright (C) 2015 - 2016 Bloomberg Finance L.P.
- * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript 
+ * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript
  * This program is free software: you can redistribute it and/or modify
  * it under the terms of the GNU Lesser General Public License as published by
  * the Free Software Foundation, either version 3 of the License, or
@@ -17,7 +17,7 @@
  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  * GNU Lesser General Public License for more details.
- * 
+ *
  * You should have received a copy of the GNU Lesser General Public License
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
@@ -30,13 +30,17 @@ 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 ]
 
-(** 
-   [bind_name] is a hint to the compiler to generate 
-   better names for external module 
+(**
+   [bind_name] is a hint to the compiler to generate
+   better names for external module
 *)
 (* let handle_external
     ({bundle ; module_bind_name} : External_ffi_types.external_module_name)
@@ -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 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 _ -> ()
+      in
       let fn = translate_scoped_module_val module_name fn scopes in
-      add_eff eff
-        ((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)
+      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

@@ -82,7 +82,7 @@ let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) :
           if nolabel then Extern_unit else Nothing
       | _ -> Nothing)
 
-(* is_optional = false 
+(* is_optional = false
 *)
 let refine_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) :
     External_arg_spec.attr =
@@ -675,7 +675,7 @@ let external_desc_of_non_obj (loc : Location.t) (st : external_desc)
          {[
            external ff : int -> int [@bs] = "" [@@module "xx"]
          ]}
-         FIXME: splice is not supported here 
+         FIXME: splice is not supported here
       *)
         Js_var { name; external_module_name = None; scopes }
       else Js_call { splice; name; external_module_name = None; scopes }
@@ -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.ml

@@ -29,7 +29,7 @@ type module_bind_name =
   | Phint_nothing
 
 
-type external_module_name = { 
+type external_module_name = {
   bundle : string ;
   module_bind_name : module_bind_name
 }
@@ -51,7 +51,7 @@ type external_spec =
       scopes : string list
     }
   | Js_module_as_var of  external_module_name
-  | Js_module_as_fn of   { 
+  | Js_module_as_fn of   {
       external_module_name : external_module_name;
       splice : bool
     }
@@ -72,13 +72,14 @@ 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 of {
       js_set_name : string  ;
       js_set_scopes : string list
     }
-  | Js_get of  { 
+  | Js_get of  {
       js_get_name : string   ;
       js_get_scopes :  string list;
     }
@@ -119,9 +120,9 @@ type return_wrapper =
   | Return_null_undefined_to_opt
   | Return_replaced_with_unit
 
-type params = 
+type params =
   | Params of   External_arg_spec.params
-  | Param_number of int 
+  | Param_number of int
 
 type t  =
   | Ffi_bs of params  *
@@ -166,7 +167,7 @@ let valid_ident (s : string) =
      true
    with E -> false )
 
-let is_package_relative_path (x : string) = 
+let is_package_relative_path (x : string) =
   Ext_string.starts_with x "./" ||
   Ext_string.starts_with x "../"
 
@@ -177,7 +178,7 @@ let valid_global_name ?loc txt =
       (fun s ->
          if not (valid_ident s) then
            Location.raise_errorf ?loc "Not a valid global name %s"  txt
-      ) 
+      )
 
 (*
   We loose such check (see #2583),
@@ -200,14 +201,14 @@ let check_external_module_name ?loc x =
 
 
 
-let check_ffi ?loc ffi : bool =  
-  let xrelative = ref false in 
-  let upgrade bool =    
-    if not (!xrelative) then xrelative := bool in 
+let check_ffi ?loc ffi : bool =
+  let xrelative = ref false in
+  let upgrade bool =
+    if not (!xrelative) then xrelative := bool in
   begin match ffi with
-    | Js_var {name; external_module_name; scopes = _} ->     
+    | Js_var {name; external_module_name; scopes = _} ->
       upgrade (is_package_relative_path name);
-      Ext_option.iter external_module_name (fun name -> 
+      Ext_option.iter external_module_name (fun name ->
           upgrade (is_package_relative_path name.bundle));
       valid_global_name ?loc  name
     | Js_send {name ;  splice = _; js_send_scopes = _}
@@ -221,10 +222,10 @@ let check_ffi ?loc ffi : bool =
     | Js_module_as_var external_module_name
     | Js_module_as_fn {external_module_name; splice = _}
     | Js_module_as_class external_module_name
-      -> 
+      ->
       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 ->
@@ -233,8 +234,8 @@ let check_ffi ?loc ffi : bool =
           check_external_module_name ?loc name
         );
 
-      valid_global_name ?loc name 
-  end; 
+      valid_global_name ?loc name
+  end;
   !xrelative
 
 (* let bs_prefix = "BS:"
@@ -255,119 +256,119 @@ let check_ffi ?loc ffi : bool =
 let to_string  (t : t) =
   Marshal.to_string t []
 
-(* \132\149\166\190 
+(* \132\149\166\190
    0x84 95 A6 BE Intext_magic_small intext.h
    https://github.com/ocaml/merlin/commit/b094c937c3a360eb61054f7652081b88e4f3612f
 *)
-let is_bs_primitive s =  
+let is_bs_primitive s =
   String.length s >= 20 (* Marshal.header_size*) &&
   String.unsafe_get s 0 = '\132' &&
-  String.unsafe_get s 1 = '\149' 
+  String.unsafe_get s 1 = '\149'
 
-let () = Oprint.map_primitive_name := 
+let () = Oprint.map_primitive_name :=
 
-# 272 "frontend/external_ffi_types.pp.ml"
+# 273 "frontend/external_ffi_types.pp.ml"
       String.escaped
 
-# 275 "frontend/external_ffi_types.pp.ml"
+# 276 "frontend/external_ffi_types.pp.ml"
 (* TODO:  better error message when version mismatch *)
 let from_string s : t =
-  if is_bs_primitive s  then   
+  if is_bs_primitive s  then
     Ext_marshal.from_string s
   else Ffi_normal
 
-let () = 
-  Primitive.coerce := 
-    (fun 
-      ({prim_name; prim_arity; prim_native_name; 
-        prim_alloc = _; 
-        prim_native_repr_args = _; 
-        prim_native_repr_res = _} : Primitive.description) 
-      (p2 : Primitive.description) -> 
-      let p2_native = p2.prim_native_name in 
-      prim_name = p2.prim_name && 
+let () =
+  Primitive.coerce :=
+    (fun
+      ({prim_name; prim_arity; prim_native_name;
+        prim_alloc = _;
+        prim_native_repr_args = _;
+        prim_native_repr_res = _} : Primitive.description)
+      (p2 : Primitive.description) ->
+      let p2_native = p2.prim_native_name in
+      prim_name = p2.prim_name &&
       prim_arity = p2.prim_arity &&
       prim_native_name = p2_native || (
-        match from_string prim_native_name, from_string p2_native with 
-        | Ffi_obj_create obj_parms, Ffi_obj_create obj_parms2 -> 
-          Ext_list.for_all2_no_exn obj_parms obj_parms2 (fun {obj_arg_type; obj_arg_label} b -> 
-              let b_obj_arg_label = b.obj_arg_label in 
+        match from_string prim_native_name, from_string p2_native with
+        | Ffi_obj_create obj_parms, Ffi_obj_create obj_parms2 ->
+          Ext_list.for_all2_no_exn obj_parms obj_parms2 (fun {obj_arg_type; obj_arg_label} b ->
+              let b_obj_arg_label = b.obj_arg_label in
               obj_arg_type = b.obj_arg_type &&
               (obj_arg_label = b_obj_arg_label  ||
-               match obj_arg_label, b_obj_arg_label with 
+               match obj_arg_label, b_obj_arg_label with
                | Obj_optional {name; for_sure_no_nested_option}, Obj_optional p
-                 -> 
+                 ->
                   name = p.name &&
                   ((Obj.magic for_sure_no_nested_option : int) <= (Obj.magic p.for_sure_no_nested_option))
-               | _ -> false  
+               | _ -> false
               )
             )
-        | Ffi_bs _, Ffi_bs _ -> false     
-        | _ -> false        
+        | Ffi_bs _, Ffi_bs _ -> false
+        | _ -> false
       )
     )
-let inline_string_primitive (s : string) (op : string option) : string list = 
-  let lam : Lam_constant.t = 
-    match op with 
+let inline_string_primitive (s : string) (op : string option) : string list =
+  let lam : Lam_constant.t =
+    match op with
     | Some op
       when Ast_utf8_string_interp.is_unicode_string op ->
       Const_unicode s
     | _ ->
-      (Const_string s) in 
+      (Const_string s) in
   [""; to_string (Ffi_inline_const lam )]
 
 (* Let's only do it for string ATM
-    for boolean, and ints, a good optimizer should     
+    for boolean, and ints, a good optimizer should
     do it by default?
     But it may not work after layers of indirection
     e.g, submodule
 *)
-let inline_bool_primitive b : string list = 
-  let lam : Lam_constant.t = 
-    if  b then Lam_constant.Const_js_true 
+let inline_bool_primitive b : string list =
+  let lam : Lam_constant.t =
+    if  b then Lam_constant.Const_js_true
     else Lam_constant.Const_js_false
-  in 
+  in
   [""; to_string (Ffi_inline_const lam )]
 
 (* FIXME: check overflow ?*)
-let inline_int_primitive (i : int32) : string list =   
-  [""; 
-   to_string 
-     (Ffi_inline_const 
+let inline_int_primitive (i : int32) : string list =
+  ["";
+   to_string
+     (Ffi_inline_const
         (Const_int {i; comment = None}))
   ]
 
-let inline_int64_primitive (i : int64) : string list =   
-  [""; 
-   to_string 
-     (Ffi_inline_const 
+let inline_int64_primitive (i : int64) : string list =
+  ["";
+   to_string
+     (Ffi_inline_const
         (Const_int64 i))
   ]
 
 let inline_float_primitive (i : string) : string list =
   ["";
-   to_string 
+   to_string
      (Ffi_inline_const (Const_float i))
-  ]    
-let rec ffi_bs_aux acc (params : External_arg_spec.params) = 
-  match params with 
-  | {arg_type = Nothing; arg_label = Arg_empty} 
+  ]
+let rec ffi_bs_aux acc (params : External_arg_spec.params) =
+  match params with
+  | {arg_type = Nothing; arg_label = Arg_empty}
     (* same as External_arg_spec.dummy*)
-    :: rest -> 
-    ffi_bs_aux (acc + 1) rest 
-  | _ :: _ -> -1    
-  | [] -> acc         
+    :: rest ->
+    ffi_bs_aux (acc + 1) rest
+  | _ :: _ -> -1
+  | [] -> acc
 
 let ffi_bs (params : External_arg_spec.params) return attr =
-  let n = ffi_bs_aux 0 params in 
-  if n < 0 then  Ffi_bs (Params params,return,attr)  
-  else Ffi_bs (Param_number n, return, attr) 
+  let n = ffi_bs_aux 0 params in
+  if n < 0 then  Ffi_bs (Params params,return,attr)
+  else Ffi_bs (Param_number n, return, attr)
 
-let ffi_bs_as_prims params return attr = 
+let ffi_bs_as_prims params return attr =
   [""; to_string (ffi_bs params return attr)]
 
 let ffi_obj_create obj_params =
   Ffi_obj_create obj_params
 
-let ffi_obj_as_prims obj_params = 
+let ffi_obj_as_prims obj_params =
   ["";to_string (Ffi_obj_create obj_params)]