diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 27c353066d..e2ba16ab08 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -224,9 +224,9 @@ end let var x = J.EVar (J.V x) -let int n = J.ENum (string_of_int n) +let int n = J.ENum (J.Num.of_int32 (Int32.of_int n)) -let int32 n = J.ENum (Int32.to_string n) +let int32 n = J.ENum (J.Num.of_int32 n) let unsigned x = J.EBin (J.Lsr, x, int 0) @@ -236,8 +236,9 @@ let zero = int 0 let plus_int x y = match x, y with - | J.ENum "0", x | x, J.ENum "0" -> x - | J.ENum x, J.ENum y -> J.ENum Int32.(to_string (add (of_string x) (of_string y))) + | J.ENum y, x when J.Num.is_zero y -> x + | x, J.ENum y when J.Num.is_zero y -> x + | J.ENum x, J.ENum y -> J.ENum (J.Num.add x y) | x, y -> J.EBin (J.Plus, x, y) let bool e = J.ECond (e, one, zero) @@ -248,8 +249,6 @@ let val_float f = f (*J.EArr [Some (J.ENum 253.); Some f]*) let float_val e = e -(*J.EAccess (e, one)*) - (****) let source_location ctx ?after pc = @@ -259,7 +258,7 @@ let source_location ctx ?after pc = (****) -let float_const f = val_float (J.ENum (Javascript.string_of_float f)) +let float_const f = val_float (J.ENum (J.Num.of_float f)) let s_var name = J.EVar (J.S {J.name; J.var = None}) @@ -1114,13 +1113,10 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list = let i, queue = let (_px, cx), queue = access_queue' ~ctx queue size in match cx with - | J.ENum i -> Int32.of_string i, queue + | J.ENum i -> Int32.to_int (J.Num.to_int32 i), queue | _ -> assert false in - let args = - Array.to_list - (Array.init (Int32.to_int i) ~f:(fun _ -> J.V (Var.fresh ()))) - in + let args = Array.to_list (Array.init i ~f:(fun _ -> J.V (Var.fresh ()))) in let f = J.V (Var.fresh ()) in let call = J.ECall diff --git a/compiler/lib/javascript.ml b/compiler/lib/javascript.ml index acb8a358a2..1fe181c861 100644 --- a/compiler/lib/javascript.ml +++ b/compiler/lib/javascript.ml @@ -19,6 +19,87 @@ *) open Stdlib +module Num : sig + type t + + (** Conversions *) + + val of_string_unsafe : string -> t + + val of_int32 : int32 -> t + + val of_float : float -> t + + val to_string : t -> string + + val to_int32 : t -> int32 + + (** Predicates *) + + val is_zero : t -> bool + + val is_one : t -> bool + + val is_neg : t -> bool + + (** Arithmetic *) + + val add : t -> t -> t + + val neg : t -> t +end = struct + type t = string + + let of_string_unsafe s = s + + let to_string s = s + + let to_int32 s = + if String.is_prefix s ~prefix:"0" + && String.length s > 1 + && String.for_all s ~f:(function + | '0' .. '7' -> true + | _ -> false) + then (* octal notation *) + Int32.of_string ("0o" ^ s) + else Int32.of_string s + + let of_int32 = Int32.to_string + + let of_float v = + if v = infinity + then "Infinity" + else if v = neg_infinity + then "-Infinity" + else if v <> v + then "NaN" (* [1/-0] = -inf seems to be the only way to detect -0 in JavaScript *) + else if v = 0. && 1. /. v = neg_infinity + then "-0." + else + let vint = int_of_float v in + if float_of_int vint = v + then Printf.sprintf "%d." vint + else + let s1 = Printf.sprintf "%.12g" v in + if v = float_of_string s1 + then s1 + else + let s2 = Printf.sprintf "%.15g" v in + if v = float_of_string s2 then s2 else Printf.sprintf "%.18g" v + + let is_zero s = String.equal s "0" + + let is_one s = String.equal s "1" + + let is_neg s = s.[0] = '-' + + let drop1 s = String.sub s ~pos:1 ~len:(String.length s - 1) + + let neg s = if is_neg s then drop1 s else "-" ^ s + + let add a b = of_int32 (Int32.add (to_int32 a) (to_int32 b)) +end + module Label = struct type t = | L of int @@ -116,7 +197,7 @@ and property_name_and_value_list = (property_name * expression) list and property_name = | PNI of identifier | PNS of string - | PNN of string + | PNN of Num.t and expression = | ESeq of expression * expression @@ -132,7 +213,7 @@ and expression = | EStr of string * [`Bytes | `Utf8] | EArr of array_litteral | EBool of bool - | ENum of string + | ENum of Num.t | EObj of property_name_and_value_list | EQuote of string | ERegexp of string * string option @@ -214,28 +295,6 @@ let compare_ident t1 t2 = | S _, V _ -> -1 | V _, S _ -> 1 -let string_of_float v = - if v = infinity - then "Infinity" - else if v = neg_infinity - then "-Infinity" - else if v <> v - then "NaN" (* [1/-0] = -inf seems to be the only way to detect -0 in JavaScript *) - else if v = 0. && 1. /. v = neg_infinity - then "-0." - else - let vint = int_of_float v in - (* compiler 1000 into 1e3 *) - if float_of_int vint = v - then Printf.sprintf "%d." vint - else - let s1 = Printf.sprintf "%.12g" v in - if v = float_of_string s1 - then s1 - else - let s2 = Printf.sprintf "%.15g" v in - if v = float_of_string s2 then s2 else Printf.sprintf "%.18g" v - exception Not_an_ident let is_ident = diff --git a/compiler/lib/javascript.mli b/compiler/lib/javascript.mli index 911d863074..367c2a8288 100644 --- a/compiler/lib/javascript.mli +++ b/compiler/lib/javascript.mli @@ -17,6 +17,37 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module Num : sig + type t + + (** Conversions *) + + val of_string_unsafe : string -> t + + val of_int32 : int32 -> t + + val of_float : float -> t + + val to_string : t -> string + + val to_int32 : t -> int32 + + (** Predicates *) + + val is_zero : t -> bool + + val is_one : t -> bool + + val is_neg : t -> bool + + (** Arithmetic *) + + val add : t -> t -> t + + val neg : t -> t +end + module Label : sig type t @@ -110,7 +141,7 @@ and property_name_and_value_list = (property_name * expression) list and property_name = | PNI of identifier | PNS of string - | PNN of string + | PNN of Num.t and expression = | ESeq of expression * expression @@ -129,7 +160,7 @@ and expression = escape sequences. *) | EArr of array_litteral | EBool of bool - | ENum of string + | ENum of Num.t | EObj of property_name_and_value_list | EQuote of string | ERegexp of string * string option @@ -200,8 +231,6 @@ and source_element = val compare_ident : ident -> ident -> int -val string_of_float : float -> string - val is_ident : string -> bool module IdentSet : Set.S with type elt = ident diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index 9dfd8b5f67..85e00df359 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -378,6 +378,7 @@ struct pp_string f ~utf:(kind = `Utf8) ~quote s | EBool b -> PP.string f (if b then "true" else "false") | ENum s -> + let s = Num.to_string s in let need_parent = if s.[0] = '-' then l > 13 (* Negative numbers may need to be parenthesized. *) diff --git a/compiler/lib/js_parser.ml b/compiler/lib/js_parser.ml index 477a1a3dd2..9dc44b1b00 100644 --- a/compiler/lib/js_parser.ml +++ b/compiler/lib/js_parser.ml @@ -23961,7 +23961,7 @@ and _menhir_run10 : _menhir_env -> 'ttv_tail -> _menhir_state -> ( let ((_1 : 'tv_numeric_literal) : 'tv_numeric_literal) = _v in ((let _v : 'tv_primary_expression_no_statement = # 418 "js_parser.mly" - ( let (start, n) = _1 in (start, J.ENum n) ) + ( let (start, n) = _1 in (start, J.ENum (J.Num.of_string_unsafe n)) ) # 23966 "js_parser.ml" in _menhir_goto_primary_expression_no_statement _menhir_env _menhir_stack _menhir_s _v) : 'freshtv40)) : 'freshtv42) @@ -23976,7 +23976,7 @@ and _menhir_run10 : _menhir_env -> 'ttv_tail -> _menhir_state -> ( let ((n : 'tv_numeric_literal) : 'tv_numeric_literal) = _v in ((let _v : 'tv_property_name = # 638 "js_parser.mly" - ( J.PNN (snd n) ) + ( J.PNN (J.Num.of_string_unsafe (snd n)) ) # 23981 "js_parser.ml" in _menhir_goto_property_name _menhir_env _menhir_stack _menhir_s _v) : 'freshtv44)) : 'freshtv46) diff --git a/compiler/lib/js_parser.mly b/compiler/lib/js_parser.mly index a0c4bd247b..f305676917 100644 --- a/compiler/lib/js_parser.mly +++ b/compiler/lib/js_parser.mly @@ -415,7 +415,7 @@ primary_expression_no_statement: | variable_with_loc { let (i, pi) = $1 in (pi, J.EVar (var i)) } | n=null_literal { n } | b=boolean_literal { b } - | numeric_literal { let (start, n) = $1 in (start, J.ENum n) } + | numeric_literal { let (start, n) = $1 in (start, J.ENum (J.Num.of_string_unsafe n)) } | T_STRING { let (s, start) = $1 in (start, J.EStr (s, `Utf8)) } (* marcel: this isn't an expansion of literal in ECMA-262... mistake? *) | r=regex_literal { r } @@ -635,7 +635,7 @@ label: property_name: | i=identifier_or_kw { J.PNI i } | s=T_STRING { J.PNS (fst s) } - | n=numeric_literal { J.PNN (snd n) } + | n=numeric_literal { J.PNN (J.Num.of_string_unsafe (snd n)) } (*************************************************************************) (* 1 xxx_opt, xxx_list *) diff --git a/compiler/lib/js_simpl.ml b/compiler/lib/js_simpl.ml index 1b22e8b8b2..a175d5330b 100644 --- a/compiler/lib/js_simpl.ml +++ b/compiler/lib/js_simpl.ml @@ -108,8 +108,9 @@ let assignment_of_statement st = let simplify_condition = function (* | J.ECond _ -> J.ENum 1. *) - | J.ECond (e, J.ENum "1", J.ENum "0") -> e - | J.ECond (e, J.ENum "0", J.ENum "1") -> J.EUn (J.Not, e) + | J.ECond (e, J.ENum one, J.ENum zero) when J.Num.is_one one && J.Num.is_zero zero -> e + | J.ECond (e, J.ENum zero, J.ENum one) when J.Num.is_one one && J.Num.is_zero zero -> + J.EUn (J.Not, e) | J.ECond (J.EBin ((J.NotEqEq | J.NotEq), J.ENum n, y), e1, e2) |J.ECond (J.EBin ((J.NotEqEq | J.NotEq), y, J.ENum n), e1, e2) -> J.ECond (J.EBin (J.Band, y, J.ENum n), e1, e2) diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml index f14dfaa3a4..ca46a79688 100644 --- a/compiler/lib/js_traverse.ml +++ b/compiler/lib/js_traverse.ml @@ -258,6 +258,7 @@ class share_constant = then Some ("str_" ^ s) else Some ("str_" ^ String.sub s ~pos:0 ~len:16 ^ "_abr") | ENum s when n > 1 -> + let s = Javascript.Num.to_string s in let l = String.length s in if l > 2 then Some ("num_" ^ s) else None | _ -> None @@ -804,7 +805,7 @@ let translate_assign_op = function | _ -> assert false let is_one = function - | ENum "1" -> true + | ENum n -> Num.is_one n | _ -> false let assign_op = function @@ -817,7 +818,7 @@ let assign_op = function else Some (EBin (PlusEq, exp, exp'')) | false, true -> if is_one exp' then Some (EUn (IncrB, exp)) else Some (EBin (PlusEq, exp, exp')) - | true, true -> Some (EBin (StarEq, exp, ENum "2"))) + | true, true -> Some (EBin (StarEq, exp, ENum (Num.of_int32 2l)))) | exp, EBin (Minus, exp', y) when exp = exp' -> if is_one y then Some (EUn (DecrB, exp)) else Some (EBin (MinusEq, exp, y)) | exp, EBin (Mul, exp', exp'') -> ( @@ -835,20 +836,24 @@ class simpl = inherit map as super method expression e = - let drop1 s = String.sub s ~pos:1 ~len:(String.length s - 1) in let e = super#expression e in + let is_zero x = + match Num.to_string x with + | "0" | "0." -> true + | _ -> false + in match e with | EBin (Plus, e1, e2) -> ( match e2, e1 with - | ENum n, _ when n.[0] = '-' -> EBin (Minus, e1, ENum (drop1 n)) - | _, ENum n when n.[0] = '-' -> EBin (Minus, e2, ENum (drop1 n)) - | ENum ("0" | "0."), (ENum _ as x) -> x - | (ENum _ as x), ENum ("0" | "0.") -> x + | ENum n, _ when Num.is_neg n -> EBin (Minus, e1, ENum (Num.neg n)) + | _, ENum n when Num.is_neg n -> EBin (Minus, e2, ENum (Num.neg n)) + | ENum zero, (ENum _ as x) when is_zero zero -> x + | (ENum _ as x), ENum zero when is_zero zero -> x | _ -> e) | EBin (Minus, e1, e2) -> ( match e2, e1 with - | ENum n, _ when n.[0] = '-' -> EBin (Plus, e1, ENum (drop1 n)) - | (ENum _ as x), ENum ("0" | "0.") -> x + | ENum n, _ when Num.is_neg n -> EBin (Plus, e1, ENum (Num.neg n)) + | (ENum _ as x), ENum zero when is_zero zero -> x | _ -> e) | _ -> e diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 155597817d..5e4c170205 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -124,6 +124,32 @@ module String = struct include StringLabels + let is_prefix ~prefix s = + let len_a = length prefix in + let len_s = length s in + if len_a > len_s + then false + else + let max_idx_a = len_a - 1 in + let rec loop i = + if i > max_idx_a + then true + else if unsafe_get prefix i <> unsafe_get s i + then false + else loop (i + 1) + in + loop 0 + + let for_all = + let rec loop s ~f ~last i = + if i > last + then true + else if f (String.unsafe_get s i) + then loop s ~f ~last (i + 1) + else false + in + fun s ~f -> loop s ~f ~last:(String.length s - 1) 0 + let is_ascii s = let res = ref true in for i = 0 to String.length s - 1 do