initial support of [this] semantics

jscomp/core.mllib

@@ -59,7 +59,6 @@ js_fold_basic
 js_fun_env
 js_pass_flatten_and_mark_dead
 js_pass_scope
-
 js_call_info
 js_pass_debug
 

jscomp/js_dump.ml

@@ -382,6 +382,8 @@ let rec pp_function method_
             P.string f L.eq ; 
             P.space f ;
             P.string f L.this;
+            P.space f ; 
+            semi f ; 
             P.newline f ;
             statement_list false cxt f b 
           );

jscomp/js_exp_make.ml

@@ -189,6 +189,7 @@ let int_to_string ?comment (e : t) : t =
 
 (* Attention: Shared *mutable state* is evil, [Js_fun_env.empty] is a mutable state ..
 *)    
+
 let ocaml_fun 
     ?comment  
     ?immutable_mask

jscomp/js_fun_env.ml

@@ -90,6 +90,7 @@ let get_mutable_params (params : Ident.t list) (x : t ) =
       Ext_list.filter_mapi 
         (fun i p -> if not xs.(i) then Some p else None)  params
 
+
 let get_unbounded t = t.unbounded
 
 let set_unbounded env v = 

jscomp/lam.ml

@@ -143,6 +143,8 @@ type primitive =
   | Pupdate_mod
   | Pjs_fn_make of int 
   | Pjs_fn_run of int 
+  | Pjs_fn_method of int 
+  | Pjs_fn_runmethod of int 
 type switch = 
   { sw_numconsts: int;
     sw_consts: (int * t) list;
@@ -562,18 +564,26 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args  : t =
   | Plazyforce -> prim ~primitive:Plazyforce ~args
 
   | Pccall a -> 
-    begin match a with 
-    | {prim_name = "js_debugger"}
+    let prim_name = a.prim_name in
+    begin match prim_name with 
+    |  "js_debugger"
       -> prim ~primitive:Pdebugger ~args 
-    | {prim_name = "js_unsafe_downgrade" }
+    | "js_unsafe_downgrade" 
       -> 
       prim ~primitive:Pjs_unsafe_downgrade ~args (* TODO: with location *)
-    | {prim_name = "js_fn_run" ; prim_native_name = arity} 
+    | "js_fn_run" 
       -> 
-      prim ~primitive:(Pjs_fn_run (int_of_string arity)) ~args 
-    | {prim_name = "js_fn_mk" ; prim_native_name = arity }
+      prim ~primitive:(Pjs_fn_run (int_of_string a.prim_native_name)) ~args 
+    |  "js_fn_mk"  
       -> 
-      prim ~primitive:(Pjs_fn_make (int_of_string arity)) ~args           
+      prim ~primitive:(Pjs_fn_make (int_of_string a.prim_native_name)) ~args           
+    | "js_fn_method"
+      ->
+      prim ~primitive:(Pjs_fn_method (int_of_string a.prim_native_name)) ~args           
+    | "js_fn_runmethod"
+      ->
+      prim ~primitive:(Pjs_fn_runmethod (int_of_string a.prim_native_name)) ~args           
+
     | _ -> 
       prim ~primitive:(Pccall a) ~args
     end

jscomp/lam.mli

@@ -134,6 +134,8 @@ type primitive =
   | Pupdate_mod
   | Pjs_fn_make of int 
   | Pjs_fn_run of int 
+  | Pjs_fn_method of int 
+  | Pjs_fn_runmethod of int 
 
 type switch  =
   { sw_numconsts: int;

jscomp/lam_analysis.ml

@@ -135,6 +135,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
       | Pjs_unsafe_downgrade
       | Pdebugger 
       | Pjs_fn_run _ | Pjs_fn_make _
+      | Pjs_fn_method _ | Pjs_fn_runmethod _
       (* TODO *)
 
       | Pbytessetu 

jscomp/lam_compile.ml

@@ -857,6 +857,42 @@ and
                App_js_full)
         | _ -> assert false 
         end
+    | Lprim {primitive = Pjs_fn_runmethod arity ; args }
+      -> 
+      begin match args with 
+      | (Lsend(Public(Some name), _label, 
+              Lprim{primitive = Pjs_unsafe_downgrade;
+                    args = [ _ ]},[], loc) as fn) :: _obj :: rest -> 
+        (* assert (Ident.same id2 id) ;  *)
+        (* we ignore the computation of [_obj], 
+           since our ast writer 
+           {[ obj#.f (x,y)
+           ]}
+           -->
+           {[ runmethod2 f obj#.f x y]}           
+        *)
+        compile_lambda cxt (Lam.apply fn rest loc App_js_full)
+      | _ -> assert false               
+      end
+    | Lprim {primitive = Pjs_fn_method arity;  args = args_lambda} -> 
+      begin match args_lambda with 
+        | [Lfunction{arity = len; kind; params = args; body} as fn] when len = arity + 1 -> 
+
+          begin 
+            match compile_lambda {cxt with st = NeedValue; should_return = False}  fn
+            with 
+          | {block ; value = Some ({expression_desc = Fun (_, params, b, env)} as f)}
+            as out
+            -> 
+            {out with value = Some {f with expression_desc = Fun(true, params, b, env)}
+            }
+          | _ -> assert false 
+          end
+
+        | _ -> assert false 
+      end
+
+
     | Lprim {primitive = Pjs_fn_make arity;  args = args_lambda} -> 
 
         begin match args_lambda with 
@@ -878,8 +914,7 @@ and
                  ]}
                  when it is passed as a function directly
               *)
-              begin 
-                match fn with 
+              begin match fn with 
                 | Lfunction {params =  [_]; body}
                   ->
                   compile_lambda cxt 
@@ -889,6 +924,7 @@ and
                        ~params:[]
                        ~body)
                 | _ -> 
+
                   compile_lambda cxt  
                     (Lam.function_ ~arity:0 
                        ~kind:Curried ~params:[] 

jscomp/lam_compile_primitive.ml

@@ -49,7 +49,11 @@ let translate
   | Pjs_unsafe_downgrade
   | Pdebugger 
   | Pjs_fn_run _ 
-  | Pjs_fn_make _ -> assert false (* already handled by {!Lam_compile} *)
+  | Pjs_fn_make _
+
+  | Pjs_fn_runmethod _ 
+    -> assert false (* already handled by {!Lam_compile} *)
+  | Pjs_fn_method _ -> assert false
   | Pinit_mod -> 
     E.runtime_call Js_config.module_ "init_mod" args
   | Pupdate_mod ->

jscomp/lam_print.ml

@@ -107,6 +107,8 @@ let primitive ppf (prim : Lam.primitive) = match prim with
   | Pjs_unsafe_downgrade -> fprintf ppf "js_unsafe_downgrade"
   | Pjs_fn_run i -> fprintf ppf "js_fn_run_%i" i 
   | Pjs_fn_make i -> fprintf ppf "js_fn_make_%i" i
+  | Pjs_fn_method i -> fprintf ppf "js_fn_method_%i" i 
+  | Pjs_fn_runmethod i -> fprintf ppf "js_fn_runmethod_%i" i 
   | Pdebugger -> fprintf ppf "debugger"
   | Pchar_to_int  -> fprintf ppf "char_to_int"
   | Pchar_of_int -> fprintf ppf "char_of_int"

jscomp/runtime/js.ml

@@ -22,7 +22,7 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-
+type (-'obj, +'a) meth = ('obj, 'a) Pervasives.meth
 
 type +'a t = 'a Pervasives.js_obj(** Js object type *)
 type +'a fn = 'a Pervasives.uncurry (** Js uncurried function *)
@@ -41,6 +41,14 @@ module Unsafe = struct
   external run1 : ('a0 * 'a1) fn -> 'a0 -> 'a1  = 
     "js_fn_run" "1"
 
+  external mk_method0 : ('obj -> 'a0) -> ('obj, 'a0) meth 
+    = 
+    "js_fn_meth" "0"
+  external mk_method1 : ('obj -> 'a0 -> 'a1) -> ('obj, 'a0 * 'a1) meth = 
+    "js_fn_meth" "1"
+  external run_method1 : 'obj -> ('obj , 'a0 * 'a1) meth -> 'a0 -> 'a1 
+    = "js_fn_runmethod" "1"
+
   external mk2 : ('a0 -> 'a1 -> 'a2 ) -> ('a0 *  'a1 * 'a2) fn = 
     "js_fn_mk" "2"
 

jscomp/stdlib/pervasives.ml

@@ -495,5 +495,6 @@ let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
 (** Mark Js object, please use {!Js.t} instead *)
 type + 'a js_obj 
 
+type (-'obj, +'a) meth
 (** Mark uncurried function, please use {!Js.fn} instead *)
-type + 'a uncurry 
+type + 'a uncurry = (< > js_obj, 'a) meth

jscomp/stdlib/pervasives.mli

@@ -1096,5 +1096,6 @@ val do_at_exit : unit -> unit
 (** Mark Js object, please use {!Js.t} instead *)
 type + 'a js_obj 
 
+type (-'obj, +'a) meth
 (** Mark uncurried function, please use {!Js.fn} instead *)
-type + 'a uncurry 
+type + 'a uncurry = (< > js_obj, 'a) meth

jscomp/syntax/ast_comb.ml

@@ -73,3 +73,44 @@ let discard_exp_as_unit loc e =
     (Exp.ident ~loc {txt = Ast_literal.Lid.ignore_id; loc})
     [Exp.constraint_ ~loc e 
        (Ast_literal.type_unit ~loc ())]
+
+
+let tuple_type_pair ?loc kind arity = 
+  let prefix  = "a" in
+  if arity = 0 then 
+    let ty = Typ.var ?loc ( prefix ^ "0") in 
+    match kind with 
+    | `Run -> ty, ty 
+    | `Make -> 
+      (Typ.arrow "" ?loc
+         (Ast_literal.type_unit ?loc ())
+         ty ,
+       ty)
+  else
+    let tys = Ext_list.init (arity + 1) (fun i -> 
+        Typ.var ?loc (prefix ^ string_of_int i)
+      )  in
+    (Ext_list.reduce_from_right (fun x y -> Typ.arrow "" ?loc x y) tys,
+     Typ.tuple ?loc  tys)
+
+
+
+let obj_type_pair ?loc arity = 
+  let obj = Typ.var ?loc "obj" in 
+  let prefix  = "a" in
+  if arity = 0 then 
+    let ty = Typ.var ?loc ( prefix ^ "0") in 
+    (Typ.arrow "" ?loc
+       obj
+       ty ,
+     (obj, ty))
+  else
+    let tys = Ext_list.init (arity + 1) (fun i -> 
+        Typ.var ?loc (prefix ^ string_of_int i)
+      )  in
+    (Typ.arrow "" ?loc obj 
+       (Ext_list.reduce_from_right (fun x y -> Typ.arrow "" ?loc x y) tys),
+     (obj, Typ.tuple ?loc  tys))
+
+
+

jscomp/syntax/ast_comb.mli

@@ -53,3 +53,15 @@ val arrow_no_label :
 *)
 val discard_exp_as_unit : 
   Location.t -> Parsetree.expression -> Parsetree.expression
+
+
+val tuple_type_pair : 
+  ?loc:Ast_helper.loc ->
+  [`Make | `Run ] -> 
+  int  ->
+  Parsetree.core_type * Parsetree.core_type
+
+
+val obj_type_pair : 
+  ?loc:Ast_helper.loc ->
+  int -> Parsetree.core_type * (Parsetree.core_type * Parsetree.core_type)

jscomp/syntax/ast_literal.ml

@@ -33,8 +33,10 @@ module Lid = struct
   (* TODO should be moved into {!Js.t} Later *)
   let pervasives_js_obj = Longident.Ldot (Lident "Pervasives", "js_obj") 
   let pervasives_uncurry = Longident.Ldot (Lident "Pervasives", "uncurry")
+  let pervasives_meth = Longident.Ldot (Lident "Pervasives", "meth")
   let js_obj = Longident.Ldot (Lident "Js", "t") 
   let js_fn = Longident.Ldot (Lident "Js", "fn")
+  let js_meth = Longident.Ldot (Lident "Js", "meth")
   let ignore_id = Longident.Ldot (Lident "Pervasives", "ignore")
 end
 

jscomp/syntax/ast_literal.mli

@@ -30,6 +30,8 @@ module Lid : sig
   val type_unit : t 
   val pervasives_js_obj : t 
   val pervasives_uncurry : t 
+  val pervasives_meth : t
+  val js_meth : t 
   val js_obj : t 
   val js_fn : t 
   val ignore_id : t