use 5.4 stdlib stuff

Author: redianthus

src/cmd/cmd_call_graph.ml

@@ -97,17 +97,17 @@ let get_const_global env id =
 
 let eval_const_instr env stack instr =
   match instr.Annotated.raw with
-  | Binary.I32_const n -> ok @@ Stack.push_i32 stack n
-  | I64_const n -> ok @@ Stack.push_i64 stack n
-  | F32_const f -> ok @@ Stack.push_f32 stack f
-  | F64_const f -> ok @@ Stack.push_f64 stack f
-  | V128_const f -> ok @@ Stack.push_v128 stack f
-  | I_binop (nn, op) -> ok @@ eval_ibinop stack nn op
-  | Ref_null t -> ok @@ Stack.push_ref stack (Concrete_ref.null t)
+  | Binary.I32_const n -> Result.ok @@ Stack.push_i32 stack n
+  | I64_const n -> Result.ok @@ Stack.push_i64 stack n
+  | F32_const f -> Result.ok @@ Stack.push_f32 stack f
+  | F64_const f -> Result.ok @@ Stack.push_f64 stack f
+  | V128_const f -> Result.ok @@ Stack.push_v128 stack f
+  | I_binop (nn, op) -> Result.ok @@ eval_ibinop stack nn op
+  | Ref_null t -> Result.ok @@ Stack.push_ref stack (Concrete_ref.null t)
   | Global_get id ->
     let* g = get_const_global env id in
-    ok @@ Stack.push_i32 stack g
-  | Ref_func id -> ok @@ Stack.push_i32_of_int stack id
+    Result.ok @@ Stack.push_i32 stack g
+  | Ref_func id -> Result.ok @@ Stack.push_i32_of_int stack id
   | _ -> assert false
 
 let eval_const env exp =

src/infra/syntax.ml

@@ -3,12 +3,7 @@
 (* Written by the Owi programmers *)
 
 open Prelude.Result
-
-let[@inline] ( let* ) o f = match o with Ok v -> f v | Error _ as e -> e
-
-let[@inline] ( let+ ) o f = match o with Ok v -> Ok (f v) | Error _ as e -> e
-
-let[@inline] ok v = Ok v
+include Syntax
 
 let[@inline] list_iter f l =
   let rec aux = function

src/infra/syntax.mli

@@ -10,8 +10,6 @@ val ( let* ) :
 val ( let+ ) :
   ('a, 'err) Prelude.Result.t -> ('a -> 'b) -> ('b, 'err) Prelude.Result.t
 
-val ok : 'a -> ('a, 'err) Prelude.Result.t
-
 val list_iter :
      ('a -> (unit, 'err) Prelude.Result.t)
   -> 'a list

src/link/link.ml

@@ -111,20 +111,20 @@ module Eval_const = struct
   (* TODO: binary+const instr *)
   let instr env stack instr =
     match instr.Annotated.raw with
-    | Binary.I32_const n -> ok @@ Stack.push_i32 stack n
-    | I64_const n -> ok @@ Stack.push_i64 stack n
-    | F32_const f -> ok @@ Stack.push_f32 stack f
-    | F64_const f -> ok @@ Stack.push_f64 stack f
-    | V128_const f -> ok @@ Stack.push_v128 stack f
-    | I_binop (nn, op) -> ok @@ ibinop stack nn op
-    | Ref_null t -> ok @@ Stack.push_ref stack (Concrete_ref.null t)
+    | Binary.I32_const n -> Result.ok @@ Stack.push_i32 stack n
+    | I64_const n -> Result.ok @@ Stack.push_i64 stack n
+    | F32_const f -> Result.ok @@ Stack.push_f32 stack f
+    | F64_const f -> Result.ok @@ Stack.push_f64 stack f
+    | V128_const f -> Result.ok @@ Stack.push_v128 stack f
+    | I_binop (nn, op) -> Result.ok @@ ibinop stack nn op
+    | Ref_null t -> Result.ok @@ Stack.push_ref stack (Concrete_ref.null t)
     | Ref_func f ->
       let* f = Link_env.Build.get_func env f in
       let value = Concrete_value.Ref (Func (Some f)) in
-      ok @@ Stack.push stack value
+      Result.ok @@ Stack.push stack value
     | Global_get id ->
       let* g = Link_env.Build.get_const_global env id in
-      ok @@ Stack.push stack g
+      Result.ok @@ Stack.push stack g
     | _ -> assert false
 
   (* TODO: binary+const expr *)
@@ -222,7 +222,7 @@ let load_memory (ls : 'f State.t)
 let eval_memory ls (memory : (Binary.Mem.t, Binary.Mem.Type.limits) Origin.t) :
   Concrete_memory.t Result.t =
   match memory with
-  | Local (_label, mem_type) -> ok @@ Concrete_memory.init mem_type
+  | Local (_label, mem_type) -> Result.ok @@ Concrete_memory.init mem_type
   | Imported import -> load_memory ls import
 
 let eval_memories ls env memories =
@@ -255,7 +255,7 @@ let load_table (ls : 'f State.t) (import : Binary.Table.Type.t Origin.imported)
 let eval_table ls (table : (Binary.Table.t, Binary.Table.Type.t) Origin.t) :
   table Result.t =
   match table with
-  | Local { id = label; typ; _ } -> ok @@ Concrete_table.init ?label typ
+  | Local { id = label; typ; _ } -> Result.ok @@ Concrete_table.init ?label typ
   | Imported import -> load_table ls import
 
 let eval_tables ls env tables =
@@ -294,7 +294,7 @@ let load_func (ls : 'f State.t) (import : Binary.block_type Origin.imported) :
 
 let eval_func ls (finished_env : int) func : func Result.t =
   match func with
-  | Origin.Local func -> ok @@ Kind.wasm func finished_env
+  | Origin.Local func -> Result.ok @@ Kind.wasm func finished_env
   | Imported import -> load_func ls import
 
 let eval_functions ls (finished_env : int) env functions =
@@ -311,7 +311,7 @@ let eval_functions ls (finished_env : int) env functions =
 let eval_tag ls (_finished_env : int)
   (tag : (Binary.Tag.t, Binary.block_type) Origin.t) : Binary.Tag.t Result.t =
   match tag with
-  | Origin.Local tag -> ok tag
+  | Origin.Local tag -> Ok tag
   | Imported import ->
     let (Binary.Bt_raw ((None | Some _), import_typ)) = import.typ in
     let* tag =
@@ -375,7 +375,7 @@ let define_data env data =
             let length = Int32.of_int @@ String.length data.init in
             let* offset = get_i32 offset in
             let* v = active_data_expr env ~offset ~length ~mem ~data:id in
-            ok @@ (v :: init)
+            Result.ok @@ (v :: init)
           | Passive -> Ok init
         in
         (env, init, succ id) )
@@ -410,7 +410,8 @@ let define_elem env elem =
             let length = Int32.of_int @@ List.length init in
             let* offset = Eval_const.expr env offset in
             let* offset = get_i32 offset in
-            ok @@ (active_elem_expr ~offset ~length ~table ~elem:i :: inits)
+            Result.ok
+            @@ (active_elem_expr ~offset ~length ~table ~elem:i :: inits)
           | Passive | Declarative -> Ok inits
         in
         (env, inits, succ i) )

src/link/link_env.ml

@@ -99,7 +99,7 @@ module Build = struct
   let get_const_global (env : t) id =
     let* g = get_global env id in
     match g.mut with
-    | Const -> ok g.value
+    | Const -> Result.ok g.value
     | Var -> Error `Constant_expression_required
 
   let get_func (env : t) id =

src/primitives/int32.ml

@@ -60,20 +60,6 @@ let extend_s n x =
 
 (* String conversion that allows leading signs and unsigned values *)
 
-(* TODO: replace by Char.Ascii.digit_to_int once on 5.4 *)
-let dec_digit = function
-  | '0' .. '9' as c -> Char.code c - Char.code '0'
-  | _ -> assert false
-[@@inline]
-
-(* TODO: replace by Char.Ascii.hex_digit_to_int once on 5.4 *)
-let hex_digit = function
-  | '0' .. '9' as c -> Char.code c - Char.code '0'
-  | 'a' .. 'f' as c -> 0xa + Char.code c - Char.code 'a'
-  | 'A' .. 'F' as c -> 0xa + Char.code c - Char.code 'A'
-  | _ -> assert false
-[@@inline]
-
 let max_upper = unsigned_div minus_one 10l
 
 let max_lower = unsigned_rem minus_one 10l
@@ -95,7 +81,7 @@ let of_string_exn s =
       let c = s.[i] in
       if Char.equal c '_' then parse_hex (i + 1) num
       else begin
-        let digit = of_int (hex_digit c) in
+        let digit = of_int (Char.Ascii.hex_digit_to_int c) in
         if not (le_u num (lshr minus_one (of_int 4))) then
           Fmt.failwith "of_string (int32)"
         else parse_hex (i + 1) (logor (shift_left num 4) digit)
@@ -108,7 +94,7 @@ let of_string_exn s =
       let c = s.[i] in
       if Char.equal c '_' then parse_dec (i + 1) num
       else begin
-        let digit = of_int (dec_digit c) in
+        let digit = of_int (Char.Ascii.digit_to_int c) in
         if not (lt_u num max_upper || (eq num max_upper && le_u digit max_lower))
         then Fmt.failwith "of_string (int32)"
         else parse_dec (i + 1) (add (mul num 10l) digit)

src/primitives/int64.ml

@@ -74,20 +74,6 @@ let extend_s n x =
 
 (* String conversion that allows leading signs and unsigned values *)
 
-(* TODO: replace by Char.Ascii.digit_to_int once on 5.4 *)
-let dec_digit = function
-  | '0' .. '9' as c -> Char.code c - Char.code '0'
-  | _ -> assert false
-[@@inline]
-
-(* TODO: replace by Char.Ascii.hex_digit_to_int once on 5.4 *)
-let hex_digit = function
-  | '0' .. '9' as c -> Char.code c - Char.code '0'
-  | 'a' .. 'f' as c -> 0xa + Char.code c - Char.code 'a'
-  | 'A' .. 'F' as c -> 0xa + Char.code c - Char.code 'A'
-  | _ -> assert false
-[@@inline]
-
 let max_upper = unsigned_div minus_one 10L
 
 let max_lower = unsigned_rem minus_one 10L
@@ -101,7 +87,7 @@ let of_string_exn s =
       let c = s.[i] in
       if Char.equal c '_' then parse_hex (i + 1) num
       else begin
-        let digit = of_int (hex_digit c) in
+        let digit = of_int (Char.Ascii.hex_digit_to_int c) in
         if not (le_u num (lshr minus_one (of_int 4))) then
           Fmt.failwith "of_string (int64)"
         else parse_hex (i + 1) (logor (shift_left num 4) digit)
@@ -114,7 +100,7 @@ let of_string_exn s =
       let c = s.[i] in
       if Char.equal c '_' then parse_dec (i + 1) num
       else begin
-        let digit = of_int (dec_digit c) in
+        let digit = of_int (Char.Ascii.digit_to_int c) in
         if not (lt_u num max_upper || (eq num max_upper && le_u digit max_lower))
         then Fmt.failwith "of_string (int64)"
         else parse_dec (i + 1) (add (mul num 10L) digit)
@@ -128,17 +114,13 @@ let of_string_exn s =
     else parse_dec i zero
   in
 
-  let parsed =
-    match s.[0] with
-    | '+' -> parse_int 1
-    | '-' ->
-      let n = parse_int 1 in
-      if not (le minus_one (sub n one)) then Fmt.failwith "of_string (int64)"
-      else neg n
-    | _ -> parse_int 0
-  in
-
-  parsed
+  match s.[0] with
+  | '+' -> parse_int 1
+  | '-' ->
+    let n = parse_int 1 in
+    if not (le minus_one (sub n one)) then Fmt.failwith "of_string (int64)"
+    else neg n
+  | _ -> parse_int 0
 
 let of_string s = try Some (of_string_exn s) with Failure _ -> None
 

src/validate/binary_validate.ml

@@ -324,7 +324,7 @@ end = struct
     | Any :: _ -> Ok [ Any ]
     | _ :: tl -> Ok tl
 
-  let push t stack = ok @@ t @ stack
+  let push t stack = Result.ok @@ t @ stack
 
   let pop_push modul (Bt_raw (_, (pt, rt)) : block_type) stack =
     let pt, rt = (List.rev_map typ_of_pt pt, List.rev_map typ_of_val_type rt) in