fix #2410, todo provide such API

rescript-lang · Dec 28, 2017 · 2de1070 · 2de1070
1 parent ee65635
commit 2de1070
Show file tree

Hide file tree

Showing 17 changed files with 485 additions and 299 deletions.
diff --git a/jscomp/Makefile b/jscomp/Makefile
@@ -265,7 +265,6 @@ CORE_SRCS= js_runtime_modules \
 	js_packages_info\
 	js_packages_state\
 	ocaml_types  \
-	ocaml_stdlib_slots \
 	bs_conditional_initial \
 	ocaml_options \
 	ocaml_parse\

diff --git a/jscomp/core/js_long.ml b/jscomp/core/js_long.ml
@@ -174,6 +174,16 @@ let min args =
   int64_call "min" args 
 let max args = 
   int64_call "max" args
+
+let equal_option args =   
+  int64_call "equal_option" args
+let equal_null args =   
+  int64_call "equal_null" args  
+let equal_undefined args =   
+  int64_call "equal_undefined" args
+let equal_nullable args =   
+  int64_call "equal_nullable" args
+
 let to_float (args : J.expression list ) = 
   match args with
   (* | [ {expression_desc  *)

diff --git a/jscomp/core/js_long.mli b/jscomp/core/js_long.mli
@@ -52,6 +52,11 @@ val or_ : int64_call
 val swap : int64_call
 val min : int64_call
 val max : int64_call
+val equal_option : int64_call
+val equal_null : int64_call
+val equal_undefined : int64_call
+val equal_nullable : int64_call
+
 val discard_sign : int64_call
 val div_mod : int64_call
 val to_hex : int64_call  

diff --git a/jscomp/core/lam_dispatch_primitive.ml b/jscomp/core/lam_dispatch_primitive.ml
@@ -289,6 +289,16 @@ let translate loc (prim_name : string)
         | [e0; e1] -> E.float_mul e0 e1 
         | _ -> assert false  
       end
+
+    | "caml_int64_equal_option"
+      -> Js_long.equal_option args 
+    | "caml_int64_equal_null"
+      -> Js_long.equal_null args 
+    | "caml_int64_equal_undefined"
+      -> Js_long.equal_undefined args 
+    | "caml_int64_equal_nullable" 
+      -> Js_long.equal_nullable args 
+
     | "caml_int64_to_float"
       -> Js_long.to_float args
     | "caml_int64_of_float"
@@ -370,6 +380,45 @@ let translate loc (prim_name : string)
           E.string_comp Ge  e0 e1
         | _ -> assert false 
       end
+    | "caml_int_equal_option" 
+    | "caml_int_equal_null"
+    | "caml_int_equal_nullable"
+    | "caml_int_equal_undefined"
+    | "caml_int32_equal_option" 
+    | "caml_int32_equal_null"
+    | "caml_int32_equal_nullable"
+    | "caml_int32_equal_undefined"
+    | "caml_nativeint_equal_option" 
+    | "caml_nativeint_equal_null"
+    | "caml_nativeint_equal_nullable"
+    | "caml_nativeint_equal_undefined"
+      ->   
+      begin match args with 
+      | [e0;e1]
+       -> E.int_comp Ceq e0 e1
+      | _ -> assert false 
+      end 
+    | "caml_float_equal_option" 
+    | "caml_float_equal_null"
+    | "caml_float_equal_nullable"
+    | "caml_float_equal_undefined"
+      ->   
+      begin match args with 
+      | [e0;e1]
+       -> E.float_comp Ceq e0 e1
+      | _ -> assert false 
+      end 
+    | "caml_string_equal_option" 
+    | "caml_string_equal_null"
+    | "caml_string_equal_nullable"
+    | "caml_string_equal_undefined"
+      ->   
+      begin match args with 
+      | [e0;e1]
+       -> E.string_comp EqEqEq e0 e1
+      | _ -> assert false 
+      end 
+
     | "caml_string_greaterthan"
       -> 
       begin match args with 
@@ -397,6 +446,8 @@ let translate loc (prim_name : string)
     | "caml_nativeint_compare"
     | "caml_float_compare"
     | "caml_string_compare" 
+
+
     -> 
       call Js_runtime_modules.caml_primitive
 
@@ -633,6 +684,11 @@ let translate loc (prim_name : string)
     | "caml_greaterthan"
     | "caml_lessequal"
     | "caml_lessthan"
+
+    | "caml_equal_option"
+    | "caml_equal_null"
+    | "caml_equal_undefined"
+    | "caml_equal_nullable"
       -> 
 
       Location.prerr_warning loc Warnings.Bs_polymorphic_comparison ; 
@@ -649,133 +705,6 @@ let translate loc (prim_name : string)
         | [e] -> E.tag e 
         | _ -> assert false end
 
-    (* Unix support *)
-    | "unix_tcdrain"
-    | "unix_tcflush"
-    | "unix_setsid"
-    | "unix_tcflow"
-    | "unix_tcgetattr"
-    | "unix_tcsetattr"
-    | "unix_tcsendbreak"
-    | "unix_getprotobynumber"
-    | "unix_getprotobyname"
-    | "unix_getservbyport"
-    | "unix_getservbyname"
-    | "unix_getservbyaddr"
-    | "unix_gethostbyname"
-    | "unix_gethostname"
-    | "unix_getpeername"
-    | "unix_accept"
-    | "unix_bind"
-    | "unix_connect"
-    | "unix_listen"
-    | "unix_shutdown"
-    | "unix_getsockname"
-    | "unix_gethostbyaddr"
-    | "unix_getgrnam"
-    | "unix_getpwuid"
-    | "unix_getgrgid"
-    | "unix_inet_addr_of_string"
-    | "unix_string_of_inet_addr"
-    | "unix_socket"
-    | "unix_socketpair"
-    | "unix_error_message"
-    | "unix_read"
-    | "unix_write"
-    | "unix_single_write"
-    | "unix_set_close_on_exec"
-    | "unix_sigprocmask"
-    | "unix_sigsuspend"
-    | "unix_recv"
-    | "unix_recvfrom"
-    | "unix_send"
-    | "unix_sendto"
-    | "unix_getsockopt"
-    | "unix_setsockopt"
-    | "unix_getaddrinfo"
-    | "unix_getnameinfo"
-    | "unix_waitpid"
-    | "unix_wait"
-    | "unix_fork"
-    | "unix_execv"
-    | "unix_dup"
-    | "unix_close"
-    | "unix_dup2"
-    | "unix_execvp"
-    | "unix_execvpe"
-    | "unix_pipe"
-    | "unix_execve"
-    | "caml_channel_descriptor"
-    | "unix_putenv"
-    | "unix_environment"
-    | "unix_lseek"
-    | "unix_getppid"
-    | "unix_getpid"
-    | "unix_nice"
-    | "unix_open"
-    | "unix_truncate"
-    | "unix_ftruncate"
-    | "unix_stat"
-    | "unix_lstat"
-    | "unix_fstat"
-    | "unix_isatty"
-    | "unix_lseek_64"
-    | "unix_truncate_64"
-    | "unix_ftruncate_64"
-    | "unix_stat_64"
-    | "unix_lstat_64"
-    | "unix_fstat_64"
-    | "unix_unlink"
-    | "unix_rename"
-    | "unix_link"
-    | "unix_chmod"
-    | "unix_fchmod"
-    | "unix_chown"
-    | "unix_fchown"
-    | "unix_umask"
-    | "unix_access"
-    | "unix_set_nonblock"
-    | "unix_clear_nonblock"
-    | "unix_clear_close_on_exec"
-    | "unix_mkdir"
-    | "unix_rmdir"
-    | "unix_chdir"
-    | "unix_getcwd"
-    | "unix_chroot"
-    | "unix_opendir"
-    | "unix_readdir"
-    | "unix_rewinddir"
-    | "unix_closedir"
-    | "unix_mkfifo"
-    | "unix_symlink"
-    | "unix_readlink"
-    | "unix_select"
-    | "unix_lockf"
-    | "unix_kill"
-    | "unix_sigpending"
-    | "unix_time"
-    | "unix_gettimeofday"
-    | "unix_gmtime"
-    | "unix_localtime"
-    | "unix_mktime"
-    | "unix_alarm"
-    | "unix_sleep"
-    | "unix_times"
-    | "unix_utimes"
-    | "unix_getitimer"
-    | "unix_setitimer"
-    | "unix_getuid"
-    | "unix_geteuid"
-    | "unix_setuid"
-    | "unix_getgid"
-    | "unix_getegid"
-    | "unix_setgid"
-    | "unix_getgroups"
-    | "unix_setgroups"
-    | "unix_initgroups"
-    | "unix_getlogin"
-    | "unix_getpwnam"
-      ->  E.not_implemented prim_name
     (* End of Unix support *)
     (* bigarrary support *)
     | "caml_ba_init"

diff --git a/jscomp/runtime/.depend b/jscomp/runtime/.depend
@@ -2,7 +2,7 @@ caml_array.cmj : caml_array.cmi
 caml_string.cmj : bs_string.cmj caml_string.cmi
 caml_bytes.cmj : caml_bytes.cmi
 caml_obj.cmj : js_null.cmj js.cmj caml_array.cmj bs_obj.cmj caml_obj.cmi
-caml_int64.cmj : js_typed_array.cmj js_float.cmj caml_utils.cmj \
+caml_int64.cmj : js_typed_array.cmj js_float.cmj js.cmj caml_utils.cmj \
     caml_int32.cmj bs_string.cmj caml_int64.cmi
 caml_exceptions.cmj : caml_builtin_exceptions.cmj caml_exceptions.cmi
 caml_utils.cmj : caml_utils.cmi
@@ -39,8 +39,8 @@ js_undefined.cmj : js.cmj js_undefined.cmi
 caml_array.cmi :
 caml_string.cmi :
 caml_bytes.cmi :
-caml_obj.cmi :
-caml_int64.cmi :
+caml_obj.cmi : js.cmi
+caml_int64.cmi : js.cmi
 caml_exceptions.cmi : caml_builtin_exceptions.cmi
 caml_utils.cmi :
 caml_sys.cmi :

diff --git a/jscomp/runtime/caml_int64.ml b/jscomp/runtime/caml_int64.ml
@@ -83,6 +83,21 @@ let add
 let not {lo; hi }  = mk ~lo:(lognot lo) ~hi:(lognot hi)
 
 let eq x y = x.hi = y.hi && x.lo = y.lo
+let equal_option x y = 
+  match y with None -> false 
+  | Some y -> eq x y 
+let equal_null x y =    
+  match Js.nullToOption y with 
+  | None -> false 
+  | Some y -> eq x y 
+let equal_undefined x y =   
+  match Js.undefinedToOption y with 
+  | None -> false 
+  | Some y -> eq x y   
+let equal_nullable x y =   
+  match Js.toOption y with 
+  | None -> false 
+  | Some y -> eq x y 
 
 let neg ({lo; hi} as x) =
   if eq x  min_int then

diff --git a/jscomp/runtime/caml_int64.mli b/jscomp/runtime/caml_int64.mli
@@ -57,6 +57,12 @@ val neq : comparison
 val lt : comparison
 val gt : comparison
 val le : comparison
+
+val equal_option : t -> t option -> bool 
+val equal_null : t -> t Js.null -> bool 
+val equal_undefined : t -> t Js.undefined -> bool 
+val equal_nullable : t -> t Js.nullable -> bool 
+
 val min : t -> t -> t 
 val max : t -> t -> t
 

diff --git a/jscomp/runtime/caml_obj.ml b/jscomp/runtime/caml_obj.ml
@@ -277,6 +277,25 @@ and aux_equal_length  (a : Obj.t) (b : Obj.t) i same_length =
     caml_equal (Obj.field a i) (Obj.field b i)
     && aux_equal_length  a b (i + 1) same_length
 
+let caml_equal_option (x : Obj.t) (y : Obj.t option) =     
+  match y with 
+  | None -> false 
+  | Some y -> caml_equal x y 
+let caml_equal_null (x : Obj.t) (y : Obj.t Js.null) = 
+  match Js.nullToOption y with    
+  | None -> x == (Obj.magic y)
+  | Some y -> caml_equal x y 
+
+let caml_equal_undefined (x : Obj.t) (y : Obj.t Js.undefined) =    
+  match Js.undefinedToOption y with 
+  | None -> x == (Obj.magic y)
+  | Some y -> caml_equal x y 
+
+let caml_equal_nullable ( x: Obj.t) (y : Obj.t Js.nullable) =    
+  match Js.toOption  y with 
+  | None -> x == (Obj.magic y)
+  | Some y -> caml_equal x y
+
 let caml_notequal a  b =  not (caml_equal a  b)
 
 let caml_greaterequal a b = caml_compare a b >= 0

diff --git a/jscomp/runtime/caml_obj.mli b/jscomp/runtime/caml_obj.mli
@@ -43,6 +43,11 @@ val caml_compare : Obj.t -> Obj.t  -> int
 type eq = Obj.t -> Obj.t -> bool
 
 val caml_equal : eq
+val caml_equal_option : Obj.t -> Obj.t option -> bool 
+val caml_equal_null : Obj.t -> Obj.t Js.null -> bool 
+val caml_equal_undefined : Obj.t -> Obj.t Js.undefined -> bool 
+val caml_equal_nullable : Obj.t -> Obj.t Js.nullable -> bool 
+
 val caml_notequal : eq
 val caml_greaterequal : eq
 val caml_greaterthan : eq

diff --git a/jscomp/test/.depend b/jscomp/test/.depend
@@ -174,6 +174,7 @@ dollar_escape_test.cmj : mt.cmj
 earger_curry_test.cmj : mt.cmj ../runtime/js.cmj ../stdlib/array.cmj
 empty_obj.cmj :
 epsilon_test.cmj : mt.cmj
+equal_box_test.cmj : mt.cmj ../runtime/js.cmj
 equal_exception_test.cmj : ../stdlib/string.cmj mt.cmj ../stdlib/bytes.cmj
 equal_test.cmj :
 es6_module_test.cmj : mt.cmj ../stdlib/list.cmj

diff --git a/jscomp/test/Makefile b/jscomp/test/Makefile
@@ -230,6 +230,7 @@ OTHERS := test_literals a test_ari test_export2 test_internalOO test_obj_simple_
 	bs_list_test\
 	bs_min_max_test\
 	bs_sort_test\
+	equal_box_test\
 # bs_uncurry_test
 # needs Lam to get rid of Uncurry arity first
 # simple_derive_test