Adding back nativeints to melange stdlib

jscomp/common/lam_constant.ml

@@ -51,6 +51,7 @@ type t =
   | Const_string of { s : string; unicode : bool }
   | Const_float of string
   | Const_int64 of int64
+  | Const_nativeint of nativeint
   | Const_pointer of string
   | Const_block of int * Lam_tag_info.t * t list
   | Const_float_array of string list
@@ -75,6 +76,7 @@ let rec eq_approx (x : t) (y : t) =
       | _ -> false)
   | Const_float ix -> ( match y with Const_float iy -> ix = iy | _ -> false)
   | Const_int64 ix -> ( match y with Const_int64 iy -> ix = iy | _ -> false)
+  | Const_nativeint ix -> ( match y with Const_nativeint iy -> ix = iy | _ -> false)
   | Const_pointer ix -> (
       match y with Const_pointer iy -> ix = iy | _ -> false)
   | Const_block (ix, _, ixs) -> (

jscomp/common/lam_constant.mli

@@ -45,6 +45,7 @@ type t =
   | Const_string of { s : string; unicode : bool }
   | Const_float of string
   | Const_int64 of int64
+  | Const_nativeint of nativeint
   | Const_pointer of string
   | Const_block of int * Lam_tag_info.t * t list
   | Const_float_array of string list

jscomp/core/lam.ml

@@ -687,6 +687,7 @@ let rec eval_const_as_bool (v : Constant.t) : bool =
   | Const_int { i = x; _ } -> x <> 0l
   | Const_char x -> Char.code x <> 0
   | Const_int64 x -> x <> 0L
+  | Const_nativeint x -> x <> 0n
   | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined ->
       false
   | Const_js_true | Const_string _ | Const_pointer _ | Const_float _

jscomp/core/lam_analysis.ml

@@ -213,7 +213,7 @@ let rec size (lam : Lam.t) =
 
 and size_constant x =
   match x with
-  | Const_int _ | Const_char _ | Const_float _ | Const_int64 _ | Const_pointer _
+  | Const_int _ | Const_char _ | Const_float _ | Const_int64 _ | Const_nativeint _ | Const_pointer _
   | Const_js_null | Const_js_undefined | Const_module_alias | Const_js_true
   | Const_js_false ->
       1

jscomp/core/lam_compile_const.ml

@@ -70,6 +70,7 @@ and translate (x : Lam.Constant.t) : J.expression =
       (* E.float (Int64.to_string i) *)
       Js_long.of_const i
       (* https://github.com/google/closure-library/blob/master/closure%2Fgoog%2Fmath%2Flong.js *)
+  | Const_nativeint i -> Nativeint.to_int32 i |> E.int
   | Const_float f -> E.float f (* TODO: preserve float *)
   | Const_string { s; unicode = false } -> E.str s
   | Const_string { s; unicode = true } -> E.unicode s

jscomp/core/lam_constant_convert.ml

@@ -60,7 +60,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam.Constant.t =
   | Const_base (Const_float i, _) -> Const_float i
   | Const_base (Const_int32 i, _) -> Const_int { i; comment = None }
   | Const_base (Const_int64 i, _) -> Const_int64 i
-  | Const_base (Const_nativeint _, _) -> assert false
+  | Const_base (Const_nativeint i, _) -> Const_nativeint i
   | Const_float_array s -> Const_float_array s
   | Const_immstring s -> Const_string { s; unicode = false }
   | Const_block (i, t, xs) -> (

jscomp/core/lam_convert.cppo.ml

@@ -189,7 +189,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
       Lam.prim ~primitive:(Pccall { prim_name = "caml_int_compare" }) ~args loc
   | Pcompare_floats ->
       Lam.prim ~primitive:(Pccall { prim_name = "caml_float_compare" }) ~args loc
-  | Pcompare_bints Pnativeint -> assert false
+  | Pcompare_bints Pnativeint -> Lam.prim ~primitive:(Pccall {prim_name = "caml_nativeint_compare" }) ~args loc
   | Pcompare_bints Pint32 ->
       Lam.prim ~primitive:(Pccall { prim_name = "caml_int32_compare" }) ~args loc
   | Pcompare_bints Pint64 ->

jscomp/core/lam_print.ml

@@ -26,6 +26,7 @@ let rec struct_const ppf (cst : Lam.Constant.t) =
   | Const_string { s; _ } -> fprintf ppf "%S" s
   | Const_float f -> fprintf ppf "%s" f
   | Const_int64 n -> fprintf ppf "%LiL" n
+  | Const_nativeint n -> fprintf ppf "%nd" n
   | Const_pointer name -> fprintf ppf "`%s" name
   | Const_some n -> fprintf ppf "[some-c]%a" struct_const n
   | Const_block (tag, _, []) -> fprintf ppf "[%i]" tag

jscomp/core/mel_ast_invariant.ml

@@ -43,10 +43,12 @@ let check_constant ~loc kind (const : Parsetree.constant) =
       *)
       try ignore (Int32.of_string s)
       with _ -> Location.prerr_warning loc Mel_integer_literal_overflow)
-  | Pconst_integer (_, Some 'n') ->
-      Location.raise_errorf ~loc
-        "`nativeint' is not currently supported in Melange. The `n' suffix \
-         cannot be used."
+  | Pconst_integer (s, Some 'n') -> (
+      (* Location.prerr_warning loc pf
+           "`nativeint' is not fully supported in Melange. The `n' suffix \
+            should be avoided."; *)
+      try ignore (Nativeint.of_string s)
+      with _ -> Location.prerr_warning loc Mel_integer_literal_overflow)
   | _ -> ()
 
 module Core_type = struct

jscomp/stdlib/nativeint.ml

@@ -0,0 +1,100 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Nativeint]: processor-native integers *)
+
+external neg: nativeint -> nativeint = "%nativeint_neg"
+external add: nativeint -> nativeint -> nativeint = "%nativeint_add"
+external sub: nativeint -> nativeint -> nativeint = "%nativeint_sub"
+external mul: nativeint -> nativeint -> nativeint = "%nativeint_mul"
+external div: nativeint -> nativeint -> nativeint = "%nativeint_div"
+external rem: nativeint -> nativeint -> nativeint = "%nativeint_mod"
+external logand: nativeint -> nativeint -> nativeint = "%nativeint_and"
+external logor: nativeint -> nativeint -> nativeint = "%nativeint_or"
+external logxor: nativeint -> nativeint -> nativeint = "%nativeint_xor"
+external shift_left: nativeint -> int -> nativeint = "%nativeint_lsl"
+external shift_right: nativeint -> int -> nativeint = "%nativeint_asr"
+external shift_right_logical: nativeint -> int -> nativeint = "%nativeint_lsr"
+external of_int: int -> nativeint = "%nativeint_of_int"
+external to_int: nativeint -> int = "%nativeint_to_int"
+external of_float : float -> nativeint
+  = "caml_nativeint_of_float" "caml_nativeint_of_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external to_float : nativeint -> float
+  = "caml_nativeint_to_float" "caml_nativeint_to_float_unboxed"
+  [@@unboxed] [@@noalloc]
+external of_int32: int32 -> nativeint = "%nativeint_of_int32"
+external to_int32: nativeint -> int32 = "%nativeint_to_int32"
+
+let zero = 0n
+let one = 1n
+let minus_one = -1n
+let succ n = add n 1n
+let pred n = sub n 1n
+let abs n = if n >= 0n then n else neg n
+let size = Sys.word_size
+let min_int = shift_left 1n (size - 1)
+let max_int = sub min_int 1n
+let lognot n = logxor n (-1n)
+
+let unsigned_to_int =
+  let max_int = of_int Stdlib.max_int in
+  fun n ->
+    if n >= 0n && n <= max_int then
+      Some (to_int n)
+    else
+      None
+
+external format : string -> nativeint -> string = "caml_nativeint_format"
+let to_string n = format "%d" n
+
+external of_string: string -> nativeint = "caml_nativeint_of_string"
+
+let of_string_opt s =
+  try Some (of_string s)
+  with Failure _ -> None
+
+type t = nativeint
+
+let compare (x: t) (y: t) = Stdlib.compare x y
+let equal (x: t) (y: t) = compare x y = 0
+
+let unsigned_compare n m =
+  compare (sub n min_int) (sub m min_int)
+
+let unsigned_lt n m =
+  sub n min_int < sub m min_int
+
+let min x y : t = if x <= y then x else y
+let max x y : t = if x >= y then x else y
+
+(* Unsigned division from signed division of the same bitness.
+   See Warren Jr., Henry S. (2013). Hacker's Delight (2 ed.), Sec 9-3.
+*)
+let unsigned_div n d =
+  if d < zero then
+    if unsigned_lt n d then zero else one
+  else
+    let q = shift_left (div (shift_right_logical n 1) d) 1 in
+    let r = sub n (mul q d) in
+    if unsigned_lt r d then q else succ q
+
+let unsigned_rem n d =
+  sub n (mul (unsigned_div n d) d)
+
+external seeded_hash_param :
+  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+let seeded_hash seed x = seeded_hash_param 10 100 seed x
+let hash x = seeded_hash_param 10 100 0 x